/* Partial MPI library based on Open Transport in the Macintosh OS,   using TCP/IP protocol.   No local buffering of messages is implemented, so that all messages   must be received in the order sent, and receives with wildcard   sources are not supported. the following subroutines are implemented:   MPI_Init, MPI_Finalize, MPI_Send, MPI_Recv, MPI_Isend, MPI_Irecv   MPI_Test, MPI_Wait, MPI_Sendrecv, MPI_Ssend, MPI_Issend, MPI_Waitall   MPI_Waitany, MPI_Get_count, MPI_Initialized, MPI_Comm_size   MPI_Comm_rank, MPI_Comm_dup, MPI_Comm_split, MPI_Comm_free   MPI_Cart_create, MPI_Cart_coords, MPI_Cart_get, MPI_Cart_shift   MPI_Cart_rank, MPI_Cart_sub, MPI_Dims_create   MPI_Bcast, MPI_Barrier, MPI_Reduce, MPI_Scan   MPI_Allreduce, MPI_Gather, MPI_Allgather, MPI_Scatter, MPI_Alltoall   MPI_Gatherv, MPI_Allgatherv, MPI_Scatterv, MPI_Alltoallv   MPI_Reduce_scatter, MPI_Abort, MPI_Wtime, MPI_Wtick, MPI_Type_extent   MPI_Request_free, MPI_Get_processor_name   Open Transport is described in Inside Macintosh: Networking with Open   Transport, verson 1.3 [Apple Computer, Cupertino, CA, 1997], and at:   http://developer.apple.com/techpubs/mac/NetworkingOT/NetworkingWOT-2.   html   The Message Passing Interface (MPI) is described in the reference,   M. Snir, S. Otto, S. Huss-Lederman, D. Walker, and J. Dongarra,   MPI: The Complete Reference [MIT Press, Cambridge, MA,1996].   The file MPIerrs is used throughout for error messages   written by viktor k. decyk, ucla   copyright 1999, regents of the university of california.   all rights reserved.   no warranty for proper operation of this software is given or implied.   software or information may be copied, distributed, and used at own   risk; it may not be distributed without this notice included verbatim   with each file.    update: march 26, 2004                                            */#define TARGET_API_MAC_CARBON        1#include <stdlib.h>#include <stdio.h>#include <string.h>#include <math.h>#include "macmpi.h"#include <Gestalt.h>#include <OpenTransport.h>#include <OpenTransportProviders.h>#include <OpenTransportProtocol.h>#include <MacMemory.h>#include <Events.h>#include <MacWindows.h>/* MAXS = maximum number of nodes connected */#define MAXS                 32/* MAXM = maximum number of outstanding messages on a node */#define MAXM                 (2*MAXS)/* MAXC = maximum number of communicators */#define MAXC                 10/* MAXD = maximum number of topology dimensions */#define MAXD                 6/* LDM = (0,1) = (NO,YES) register AppleTalk port for Launch Den Mother */#define LDM                  0/* internal mpi common block   nproc = number of real or virtual processors obtained   idproc = processor id   cfig0 = OTConfiguration structure template   epref = array of endpoint references for each participating node   ioc = array of context pointers for notifier function   nevents = log of unknown notifier events   stime = first time stamp if MPI_Init successful   mapcomm = communicator map                                       */   static int nproc = -1, idproc;   static OTConfigurationRef cfig0 = 0;   static EndpointRef epref[MAXS+1];   static int ioc[MAXS+1][4], nevents[MAXS+1], mapcomm[MAXC][MAXS+MAXD+3];   static OTTimeStamp stime;   static OTNotifyUPP notifierUPP = 0;      /* internal common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages   curreq = request record for transmission parameters   header = message envelope   rwrec = read/write record for asynchronous messages   trash = trash bin for unwanted data   mqueue = message request queue                                     */   struct RWRec {      EndpointRef ref;      int ioflag;      void *buf;      size_t nbytes;      OTFlags flags;      void *sbuf;      int sln;      int len;      OTTimeStamp ts[2];      int nextm;      int nfatal;   };   struct ipdata {      OTData first;      OTData second;      int hdata[4];   };   static int monitor = 1, curreq[MAXM][5], mqueue[MAXS+1][2];   static struct ipdata header[MAXM];   static struct RWRec rwrec[MAXM];   static unsigned char trash[1024];/* internal common block for message window   cpptr = pointer to window structure   crect = current drag region   nsp = amount of space between boxes   nbx = size of box   nds = number of message sizes monitored   mbs = maximum maximum bandwidth in MB/sec expected */   static WindowPtr cpptr = 0;   static Rect crect;   static short nsp = 8, nbx = 16, nds = 24, mbs = 10;/* internal common block for adsp   nameid = adsp portname ID      */   static OTNameID nameid = 0;static FILE *unit2;/* prototypes for internal procedures */int regport(int portnum);void delport();static pascal void notifier(void* context, OTEventCode event, OTResult result,                            void* cookie);long otpinit(int np, TBind *reqad, TBind *repad);long setopts(EndpointRef epref, unsigned long level, unsigned long name, long *value);int ioresult(int *pblock);int checkesc(long stk);void sndmsgf(MPI_Request request, int dest);void rcvmsgf(MPI_Request request, int source);static int imax(int val1, int val2);static int imin(int val1, int val2);static float flmax(float val1, float val2);static float flmin(float val1, float val2);static double dmax(double val1, double val2);static double dmin(double val1, double val2);static void iredux(int *recvbuf, int *sendbuf, int offset, int count, MPI_Op op);static void fredux(float *recvbuf, float *sendbuf, int offset, int count, MPI_Op op);  static void dredux(double *recvbuf, double *sendbuf, int offset, int count, MPI_Op op);void writerrs(char *source, int ierror);void rwstat(int request, FILE *unit);void wqueue(FILE *unit);void messwin(int nvp);void logmess(int idp, int lstat, int lsize, int mticks, int tag);void showmess(int idp, int istat, int istyle);void showdism(int ibin, int nbin, int mbin, int lmax, int istyle);void shospeed(float atime, float ctime, float arate, float crate);void Logname(char *name);void Set_Mon(int monval);int Get_Mon();void delmess();/* function definitions */int MPI_Init(int *argc, char ***argv) {/* initialize the MPI execution environment   input: argc, argv, output: nonelocal data                                  */   int ierror, nerr, nv, i;   int portnum = 0, pshift = 0, pnumid[3], epnum[8];   long oss, response;   char *cnerr = 0;   OTConfigurationRef cfig = 0;   EndpointRef epref0 = 0;   TEndpointInfo epinfo;   InetInterfaceInfo info;   InetHost address, oldadd;   char ename[36], myself[18], location[18], fname[18];   InetAddress addrb, addrl, addrn;   TBind reqad, repad;   TCall scall;   OTTimeStamp ptime, delta;   MPI_Status stat;   FILE *unit3;/* internal mpi common block   nproc = number of real or virtual processors obtained   idproc = processor id   cfig0 = OTConfiguration structure template   epref = array of endpoint references for each participating node   ioc = array of context pointers for notifier function   ioc[i][0] = endpoint reference for notifier for endpoint i   ioc[i][1] = processor id for listener for endpoint i   ioc[i][2] = handle for current receive from endpoint i   ioc[i][3] = handle for current send to endpoint i   nevents = log of unknown notifier events   stime = first time stamp if MPI_Init successful   mapcomm = communicator map   mapcomm[i][0:nproc-1] = actual proc id for given rank in communicator i   mapcomm[i][nproc:MAXS-1] = MPI_UNDEFINED   mapcomm[i][MAXSi] = number of processes in comm i   mapcomm[i][MAXS+1] = rank for this node in comm i   mapcomm[i][MAXS+2] = ndims = number of dimensions in topology in comm i   mapcomm[i][iMAXS+3:MAXS+2+ndims] = size of dimension in comm i,   negative if non-periodic   mapcomm[i][MAXS+3+ndims:MAXS+2+MAXD] = 0                             */  /* internal common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages   curreq = request record for transmission parameters, see rwstat   header = message envelope   hdata[i][0] = communicator, hdata[i][1] = tag, hdata[i][2] = datatype   hdata[i][3] = length of data (in bytes) for message handle i   rwrec = read/write record for asynchronous messages, see rwstat   mqueue = message request queue   mqueue[i][0] = end of message queue for receives from endpoint i   mqueue[i][1] = end of message queue for sends to endpoint i          *//* internal common block for adsp   epref0 = endpoint reference used by tcp and adsp providers *//* Initialize common block data */   for (i = 0; i < MAXS+1; i++) {      epref[i] = 0;      nevents[i] = 0;      for (nv = 0; nv < 2; nv++)         mqueue[i][nv] = 0;   }   for (i = 0; i < MAXC; i++) {      for (nv = 0; nv < MAXS+MAXD+3; nv++)         mapcomm[i][nv] = 0;   }   for (i = 0; i < MAXM; i++) {      for (nv = 0; nv < 5; nv++)         curreq[i][nv] = 0;   }/* set MPI_COMM_WORLD and MPI_COMM_SELF mapping */   for (i = 0; i < MAXS; i++) {      mapcomm[0][i] = i;      mapcomm[1][i] = MPI_UNDEFINED;   }/* Open error file */   unit2 = fopen("MPIerrs","w");   if (monitor==2)      fprintf(unit2,"MPI_Init started\n");/*   Open Open Transport*//* get information about the operating environment */   Gestalt(gestaltSystemVersion,&response);/* Check if MacOS 8.6 or higher is installed */   if (response < 2144) {      fprintf(unit2,"MacMPI_X requires MacOS 8.6 or higher\n");      nv = response/256;      response = response - 256*nv;      nerr = response/16;      response = response - 16*nerr;      sprintf(ename,"%d.%d%d\n",nv,nerr,response);      fprintf(unit2,"MacOS detected: %s\n",ename);      ierror = -7;      return ierror;   }/* Initialize Open Transport for use by application */   oss = InitOpenTransportInContext(kInitOTForApplicationMask,NULL);   if (oss) {      fprintf(unit2,"Cannot Open Transport, oss = %d\n",oss);      ierror = oss;      return ierror;   }/* Obtain the current time stamp */   OTGetTimeStamp(&stime);/* Create a structure defining a provider's configuration */   cfig0 = OTCreateConfiguration("tcp");   if (!cfig0) {      fprintf(unit2,"Insufficient Memory for tcp Endpoint\n");      ierror = -4;      CloseOpenTransportInContext(NULL);      return ierror;   }   else if (cfig0==((OTConfigurationRef)-1L)) {      fprintf(unit2,"Invalid Configuration for tcp Endpoint\n");      ierror = -4;      CloseOpenTransportInContext(NULL);      return ierror;   }/* Copy an OTConfiguration structure */   cfig = OTCloneConfiguration(cfig0);/* Create a synchronous endpoint provider */   epref0 = OTOpenEndpointInContext(cfig,0,&epinfo,&oss,NULL);/* Obtain information about the Internet environment */   oss = OTInetGetInterfaceInfo(&info,kDefaultInetInterface);   if (oss) {      fprintf(unit2,"INS GetInterfaceInfo Error, oss = %d\n",oss);      if (oss==kOTNotFoundErr) {         fprintf(unit2,"Requested information does not exist\n");         fprintf(unit2,"TCP/IP may not be active\n");      }      ierror = oss;      oss = OTCloseProvider(epref0);      CloseOpenTransportInContext(NULL);      return ierror;   }/* Close the dummy endpoint provider */   oss = OTCloseProvider(epref0);   address = info.fAddress;   oldadd = address;/*   Everyone opens a port*//* Open file containing portnum (and possibly participating nodes)   first line in nodelist file on all nodes contains common portnum   if the file is missing or empty, a default number of 5013 is used */   unit3 = fopen("nodelist_ip","r");   if (!unit3)      unit3 = fopen("nodelist","r");   if (unit3) {      cnerr = fgets(location,11,unit3);      if (!cnerr)         strcpy(location,"5013");/* Replace trailing newlines with nulls */      cnerr = strchr(location,'\n');      if (cnerr)         cnerr[0] = '\0';      if (location[0]=='\0')         strcpy(location,"5013");   }   else      strcpy(location,"5013");/* Convert string to integer */   nerr = sscanf(location,"%d",&portnum);   if ((!nerr) || (portnum < 5000) || (portnum > 49152))      portnum = 5013;/* Construct InetAddress of listener */   addrn.fAddressType = AF_INET;   addrn.fPort = portnum;   addrn.fHost = info.fAddress;/* Convert an address into a character string */   OTInetHostToString(addrn.fHost,myself);   strcpy(ename,myself);/* Establish port connection end *//* Set TNetbuf for specifying address */   reqad.addr.len = 16;   reqad.addr.buf = (unsigned char *)&addrn;   reqad.qlen = 1;/* Set TNetbuf for address which is returned */   repad.addr.maxlen = 16;   repad.addr.buf = (unsigned char *)&addrb;/* Set TNetbuf for specifying address for local computer */   scall.addr.len = 16;   scall.addr.buf = (unsigned char *)&addrn;   nproc = 0;/* Create Univeral Proc Ptr for notifier function */   notifierUPP = NewOTNotifyUPP(&notifier);/* Initialize synchronous listener endpoint provider */   oss = otpinit(MAXS,&reqad,&repad);   if (oss) {      if (oss==kOTNoAddressErr)         fprintf(unit2,"portnum likely already exists = %d\n",portnum);      ierror = oss;      nerr = MPI_Finalize();      return ierror;   }/* Save copy of portnum */   pnumid[0] = addrn.fPort;/* Register adsp endpoint for puppy */   if (LDM) {      ierror = regport(portnum);      if (ierror) {         fprintf(unit2,"Unable to register adsp port for puppy\n");/*       nerr = MPI_Finalize(); */      }   }/* Pass processor id to listener notifier */   ioc[MAXS][1] = nproc + 1;/* debug */   if (monitor==2) {      fprintf(unit2,"local host=%s,port=%d\n",myself,addrb.fPort);   }/*   Determine if node is master (idproc=0) or slave (idproc>0).   on the master node, the second and subsequent lines of nodelist file   contain IP addresses of the nodes participating, in dotted-decimal   format (for example, "12.13.14.15").   if this list of nodes is missing, then the node is a slave.   every node also makes a connection to itself.*/   if (unit3) {      cnerr = fgets(location,17,unit3);   }/* Must be slave */   if (!unit3 || !cnerr)      idproc = 1;   else {/* Replace trailing newlines with nulls */      cnerr = strchr(location,'\n');      if (cnerr)         cnerr[0] = '\0';/* Must be slave */      if (location[0]=='\0')         idproc = 1;/* May be master */      else {         if (((!strcmp(location,"self")) || (!strcmp(location,myself)))            && (pnumid[0]==portnum)) {            idproc = 0;/* Delete file if empty */            if (!fseek(unit2,0,SEEK_END)) {               i = ftell(unit2);               fclose(unit2);               if (!i)                  remove("MPIerrs");            }            sprintf(fname,"MPIerrs%.2d",idproc);            unit2 = fopen(fname,"w");         }         else/* Must be slave */            idproc = 1;      }   }/* Update port number */   portnum = pnumid[0];/*    * * * begin main iteration loop * * *   Prepare to accept connection*//* Establish connection end *//* Connections to oneself requires a new socket */L10: addrb.fPort = kOTAnyInetAddress;/* Set TNetbuf for specifying address */   reqad.addr.len = 16;   reqad.addr.buf = (unsigned char *)&addrb;   reqad.qlen = 0;/* Set TNetbuf for address which is returned */   repad.addr.maxlen = 16;   repad.addr.buf = (unsigned char *)&addrl;/* Initialize synchronous endpoint provider */   oss = otpinit(nproc,&reqad,&repad);   if (oss) {      ierror = oss;      nerr = MPI_Finalize();      return ierror;   }/* For connections to oneself, jump to OTConnect */   if (idproc==nproc) {      ioc[MAXS][1] = MAXS+1;      goto L70;   }/* Obtain the current time stamp */   OTGetTimeStamp(&ptime);/* Wait for connection */L20: if (ioresult(ioc[MAXS]) > 0) {      if (checkesc(1)) {         ierror = -9;         writerrs("MPI_Init: ",ierror);         return ierror;      }/* Wait up to one minute for next connection */      else {         if (OTElapsedMilliseconds(&ptime) < 60000)            goto L20;         else {            fprintf(unit2,"OTListen Wait Time Exceeded\n");            ierror = -5;            nerr = MPI_Finalize();            return ierror;         }      }   }   else {      oss = ioresult(ioc[MAXS]);      if (oss) {         fprintf(unit2,"OTListen failed, oss=%d\n",oss);         ierror = oss;         nerr = MPI_Finalize();         return ierror;      }   }/* Receive portnum for verification and processor id from remote node */   nproc += 1;   mapcomm[0][MAXS] = nproc;/* Reset iocompletion flag to notifier */   ioc[MAXS][1] = nproc + 1;   ierror = MPI_Recv(epnum,3,MPI_INT,nproc-1,3,0,&stat);/* Extract processor id on first connection */   if (nproc==1) {      idproc = epnum[1];      pshift = portnum - epnum[2];      portnum = epnum[2];      mapcomm[0][MAXS+1] = idproc;/* Delete file if empty */      if (!fseek(unit2,0,SEEK_END)) {         i = ftell(unit2);         fclose(unit2);         if (!i)            remove("MPIerrs");      }      sprintf(fname,"MPIerrs%.2d",idproc);      unit2 = fopen(fname,"w");   }/* Check if remote portnum agrees with local portnum */   nerr = pnumid[0] - epnum[0];/* Send reject flag to remote node */   ierror = MPI_Send(&nerr,1,MPI_INT,nproc-1,4,0);/* Reject if portnums disagree */   if (nerr) {      fprintf(unit2,"Session rejected, idproc = %d\n",idproc);      fprintf(unit2,"Portnums do not agree\n");      ierror = 5;      fprintf(unit2,"remote portnum = %d\n",epnum[0]);      nerr = MPI_Finalize();      return ierror;   }/* Check for processor number overflow */   if (nproc > MAXS) {      fprintf(unit2,"processor number overflow, nproc = %d\n",nproc);      ierror = 6;      nerr = MPI_Finalize();      return ierror;   }/* debug */   if (monitor==2)      fprintf(unit2,"connection accepted with idproc=%d\n",nproc-1);/* Accept more connections */   if (idproc >= nproc)      goto L10;/*   Master prepares to start connection*//* Find internet address of requested node *//* Convert a character string into an address */L40: oss = OTInetStringToHost(location,&address);   if (oss) {      fprintf(unit2,"OTInetStringToHost failed, oss = %d\n",oss);      if (oss==kOTBadAddressErr) {         fprintf(unit2,"Invalid IP address = %s\n",location);         fprintf(unit2,"Invalid nodelist file possibly being used\n");      }      ierror = oss;      nerr = MPI_Finalize();      return ierror;   }/* second cpu on a node uses incremented port number */   if (address==oldadd)      pshift = pshift + 1;   else {      pshift = 0;      oldadd = address;   }   pnumid[0] = portnum + pshift;   addrn.fAddressType = AF_INET;   addrn.fPort = pnumid[0];   addrn.fHost = address;/* Convert an address into a character string */   OTInetHostToString(addrn.fHost,ename);/* Establish connection end *//* Create a new socket for this endpoint */   addrb.fPort = kOTAnyInetAddress;/* Set TNetbuf for specifying address */   reqad.addr.len = 16;   reqad.addr.buf = (unsigned char *)&addrb;   reqad.qlen = 0;/* Set TNetbuf for address which is returned */   repad.addr.maxlen = 16;   repad.addr.buf = (unsigned char *)&addrl;/* Initialize synchronous endpoint provider */   oss = otpinit(nproc,&reqad,&repad);   if (oss) {      ierror = oss;      nerr = MPI_Finalize();      return ierror;   }/* Set TNetbuf for specifying address for remote computer */   scall.addr.len = 16;   scall.addr.buf = (unsigned char *)&addrn;/* Set TNetbuf for specifying options */L70: scall.opt.len = 0;   scall.opt.buf = 0;/* Set TNetbuf for specifying data */   scall.udata.len = 0;   scall.udata.buf = 0;/* debug */   if (monitor==2)      fprintf(unit2,"requesting connection with =%s,%d\n",ename,pnumid[0]);/* Pause to let OS get some time */   if (checkesc(1)) {      ierror = -9;      writerrs("MPI_Init: ",ierror);      return ierror;   }/* Obtain the current time stamp */   OTGetTimeStamp(&ptime);   OTGetTimeStamp(&delta);/* Request a connection to a remote peer */   oss = OTConnect(epref[nproc],&scall,0);/* Wait for connection */L80: if (ioresult(ioc[nproc]) > 0) {      if (checkesc(1)) {         ierror = -9;         writerrs("MPI_Init: ",ierror);         return ierror;      } /* Wait up to one minute for next connection */      else {         if (OTElapsedMilliseconds(&ptime) < 60000) {            response = OTGetEndpointState(epref[nproc]);/* Try again every second if no response */            if ((response < 5) && (OTElapsedMilliseconds(&delta) > 1000)) {               oss = OTConnect(epref[nproc],&scall,0);/* Obtain the current time stamp */               OTGetTimeStamp(&delta);            }            goto L80;         }         else {            fprintf(unit2,"OTConnect Wait Time Exceeded\n");            fprintf(unit2,"Trying to start location = %s,%d\n",ename,pnumid[0]);            ierror = -6;            nerr = MPI_Finalize();            return ierror;         }      }   }   else {      oss = ioresult(ioc[nproc]);      if (oss) {         fprintf(unit2,"OTConnect Error, oss = %d\n",oss);         fprintf(unit2,"Trying to start location = %s,%d\n",ename,pnumid[0]);         if (oss==kOTOutStateErr) {            fprintf(unit2,"Endpoint not in an appropriate state\n");            fprintf(unit2,"Remote node may be unknown or inaccessible\n");         }         ierror = oss;         nerr = MPI_Finalize();         return ierror;      }   }/* debug */   if (monitor==2)      fprintf(unit2,"tentative connection started with =%s,%d\n",ename,pnumid[0]);/* Send portnum for verification and processor id to remote node */   nerr = nproc;   nproc += 1;   mapcomm[0][MAXS] = nproc;   if (nerr > idproc) {/* Set processor id */      pnumid[1] = nerr;      pnumid[2] = portnum;      ierror = MPI_Send(pnumid,3,MPI_INT,nproc-1,3,0);/* Read and check reject flag */      ierror = MPI_Recv(&nerr,1,MPI_INT,nproc-1,4,0,&stat);      if (nerr) {         fprintf(unit2,"Connection rejected, reject info = %d\n",nerr);         fprintf(unit2,"Portnums do not agree, idproc = %d\n",nproc-1);         ierror = 12;         nerr = MPI_Finalize();         return ierror;      }   }/* Check for processor number overflow */   if (nproc > MAXS) {      fprintf(unit2,"processor number overflow, nproc = %d\n",nproc);      ierror = 6;      nerr = MPI_Finalize();      return ierror;   }/* debug */   if (monitor==2)      fprintf(unit2,"connection confirmed with idproc=%d\n",nproc-1);/* Pass current location to next node */   if (nproc > (idproc+2))      nerr = MPI_Send(location,4,MPI_INT,idproc+1,1,0);/* Read location of next node from file */   if (idproc==0) {      if ((nproc >= 2) || (!strcmp(location,"self")) || (!strcmp(location,myself))) {         if (!unit3)            goto L90;         cnerr = fgets(location,17,unit3);         if (!cnerr)            goto L90;/* Replace trailing newlines with nulls */         cnerr = strchr(location,'\n');         if (cnerr)            cnerr[0] = '\0';         if (location[0]=='\0')            goto L90;      }   }/* Receive location of next node from another processor */   else {      nerr = MPI_Recv(location,4,MPI_INT,idproc-1,1,0,&stat);/* End of file marker received */      if (stat.len==0)         goto L90;   }/* Start another connection */   goto L40;/*    * * * end main iteration loop * * **//* All expected nodes activated */L90: nv = nproc - 1;/* debug */   if (monitor==2)      fprintf(unit2,"all nodes activated, idproc, nproc=%d,%d\n",              idproc,nproc);/* Send null record to next processor */   if (idproc < nv)      nerr = MPI_Send(location,0,MPI_INT,idproc+1,1,0);   if (unit3)      fclose(unit3);/* Check number of processors */   if (idproc==nv) {      for (i = 1; i <= nv; i++) {         nerr = MPI_Send(&nproc,1,MPI_INT,nv-i,2,0);      }   }   else {      nerr = MPI_Recv(&response,1,MPI_INT,nv,2,0,&stat);/* Local processor does not agree with last processor on total number */      if (response != nproc) {         fprintf(unit2,"processor number error, local/remote nproc = %d,%d\n",                 nproc,response);         ierror = 7;         nerr = MPI_Finalize();         return ierror;      }   }/* Clear unused MPI_COMM_WORLD mapping */   for (i = nproc; i < MAXS; i++) {      mapcomm[0][i] = MPI_UNDEFINED;   }   mapcomm[0][MAXS+2] = 0;/* set MPI_COMM_SELF */   mapcomm[1][0] = idproc;   mapcomm[1][MAXS] = 1;   mapcomm[1][MAXS+1] = 0;   mapcomm[1][MAXS+2] = 0;/* Create window for showing MPI message status */      if (monitor > 0) {         messwin(nproc);         checkesc(1);         if (monitor==2)            fprintf(unit2,"MPI_Init complete\n\n");      }/* Set error code to success */   ierror = 0;   return ierror;}int regport(int portnum) {/* Finds name of current computer by first finding network address of   current computer, then finding a registered entity with type name   "PPCToolBox" which resides at that address.  The object name   corresponding to that entity is the current computer name.  This only   works if the user has set Program Linking on in the File Sharing   control panel.  If computer name is found, then a portname is created   whose entity name consists of object = computer name, type = portnum   If it already exists, it is first deleted, then registered.local data */#include <OpenTptAppleTalk.h>/* kATalkFullSelfSend = command to turn on classic ADSP SelfSend */#define kATalkFullSelfSend   (MIOC_CMD(MIOC_ATALK,47))   int ierror, address, nodeid, nv, i;   long oss;   unsigned char selfsend = 1;   unsigned char *ucptr = 0;   OTConfigurationRef cfig = 0;   ATSvcRef aref = 0;   TNetbuf info;   struct AppleTalkInfo atinfo;   MapperRef mref = 0;   TLookupRequest req;   char ename[36];   unsigned char rbuff[1888];   TLookupReply rep;   TLookupBuffer *club;   DDPAddress addrb;   NBPEntity aname;   NBPAddress addrn;   TRegisterRequest treq;   TRegisterReply trep;/* internal common block for adsp   nameid = adsp portname ID      */   ierror = 0;/* Open a synchronous AppleTalk service provider */   aref = OTOpenAppleTalkServicesInContext(kDefaultAppleTalkServicesPath,0,&oss,NULL);   if (!aref) {      fprintf(unit2,"Invalid ATS, oss=%d\n",oss);      ierror = oss;      return ierror;   }/* Set TNetbuf to receive AppleTalk Info */   info.maxlen = sizeof(struct AppleTalkInfo);   info.len = 0;   info.buf = (unsigned char *)&atinfo;/* Obtain information about the AppleTalk environment */   oss = OTATalkGetInfo(aref,&info);   if (oss) {      fprintf(unit2,"ATS GetInfo Error, oss = %d\n",oss);      ierror = oss;      OTCloseProvider(aref);      return ierror;   }   address = atinfo.fOurAddress.fNetwork;   nodeid = atinfo.fOurAddress.fNodeID;/* Close a provider of any type */   oss = OTCloseProvider(aref);   if (oss)      fprintf(unit2,"Close ATS Provider Error, oss = %d\n",oss);/* Create a structure defining a provider's configuration */   cfig = OTCreateConfiguration("nbp");   if (!cfig) {      fprintf(unit2,"Insufficient Memory for nbp Mapper\n");      ierror = -4;      return ierror;   }   else if (cfig==((OTConfigurationRef)-1L)) {      fprintf(unit2,"Invalid Configuration for nbp Mapper\n");      ierror = -4;      return ierror;   }/* Create a synchronous mapper provider */   mref = OTOpenMapperInContext(cfig,0,&oss,NULL);   if (!mref) {      fprintf(unit2,"Invalid NBP Mapper, oss=%d\n",oss);      ierror = oss;      OTDestroyConfiguration(cfig);      return ierror;   }/* Enable ADSP SelfSend *//* Send a module-specific command to Open Transport protocol module */   oss = OTIoctl(mref,kATalkFullSelfSend,(void *)selfsend);   if (oss < 0)      fprintf(unit2,"OTIoctl SelfSend Error, oss=%d\n",oss);/* Save old value */   else      selfsend = oss;/* Set a provider to wait or block until function can complete */   oss = OTSetBlocking(mref);   if (oss) {      fprintf(unit2,"NBP Mapper Set Blocking Error, oss = %d\n",oss);      ierror = oss;      OTCloseProvider(mref);      return ierror;   }/* Look for names with type "PPCToolBox" */   strcpy(ename,"=:PPCToolBox@*");/* Set TNetbuf for name to be looked up */   req.name.len = 14;   req.name.buf = (unsigned char *)ename;/* Set TNetbuf to use defaults for address search */   req.addr.len = 0;   req.addr.buf = 0;/* Set number of names you expect to be returned */   req.maxcnt = 16;/* Set timeout to default */   req.timeout = 0;   req.flags = 0;/* Set TNetbuf for names which are found */   rep.names.maxlen = 1888;   rep.names.buf = &rbuff[0];/* Find all addresses that correspond to a particular name or pattern */   oss = OTLookupName(mref,&req,&rep);   if (oss) {      fprintf(unit2,"OTLookup Error, rspcount, oss = %d,%d\n",              rep.rspcount,oss);      if (oss==kOTNoDataErr)         fprintf(unit2,"Cannot find PPCToolBox on any computer\n");      ierror = oss;   }   else {      nv = 0;      i = 1;L5:   club = (TLookupBuffer *)&rbuff[nv];/* Get network address of found entity */      addrb = *(DDPAddress *)&club->fAddressBuffer[0];/* Check if network and nodeid agrees */      if ((addrb.fNetwork != address) || (addrb.fNodeID != nodeid)) {         i += 1;         if (i > rep.rspcount) {            fprintf(unit2,"Cannot find PPCToolBox on current computer\n");            ierror = 8;         }/* Look up more addresses */         else {            nv += ((club->fAddressLength-1)/4                     + (club->fNameLength-1)/4 + 3)*4;            goto L5;         }      }/* Found correct address */      else         ierror = 0;   }   if (ierror) {      fprintf(unit2,"Program Linking may not be enabled\n");      OTCloseProvider(mref);      return ierror;   }/* Extract object name */   nv = club->fAddressLength;   ucptr = (unsigned char *)&club->fAddressBuffer[nv];   nv = club->fNameLength;   OTSetNBPEntityFromAddress(&aname,ucptr,nv);/* Check if port name is already being used */   sprintf(ename,"%d",portnum);/* Set the type part of an NBP entity structure */   OTSetNBPType(&aname,ename);/* Set the zone part of an NBP entity structure */   OTSetNBPZone(&aname,"*");/* Store an NBP entity structure as an NBP address string */   OTSetAddressFromNBPEntity(addrn.fNBPNameBuffer,&aname);   addrn.fAddressType = 258;/* Obtain the size of an NBP entity structure formatted as string */   nv = OTGetNBPEntityLengthAsAddress(&aname);   addrn.fNBPNameBuffer[nv] = '\0';/* Set TNetbuf for name to be deleted */   info.len = nv;   info.buf = addrn.fNBPNameBuffer;/* Remove a previously registered entity name */   oss = OTDeleteName(mref,&info);   if (!oss)      fprintf(unit2,"closed old adsp port: %s\n",addrn.fNBPNameBuffer);/* Set TNetbufs for name to be registered */   treq.name.len = nv;   treq.name.buf = addrn.fNBPNameBuffer;   treq.addr.len = 0;   treq.addr.buf = 0;   treq.flags = 0;   trep.addr.maxlen = 8;   trep.addr.buf = (unsigned char *)&addrb;   trep.nameid = 0;/* Register a name on the network */   oss = OTRegisterName(mref,&treq,&trep);   nameid = trep.nameid;   if (oss)      fprintf(unit2,"OTRegisterName Error, oss = %d\n",oss);/* Close a provider of any type */   oss = OTCloseProvider(mref);   if (oss)      fprintf(unit2,"Close NBP Provider Error, oss = %d\n",oss);   return ierror;#undef kATalkFullSelfSend}void delport() {/* this subroutine deletes adsp portnamelocal data */   long oss;   OTConfigurationRef cfig = 0;   MapperRef mref = 0;/* internal common block for adsp   nameid = adsp portname ID      *//* Create a structure defining a provider's configuration */   cfig = OTCreateConfiguration("nbp");   if (!cfig) {      fprintf(unit2,"delport: Insufficient Memory for nbp Mapper\n");      return;   }   else if (cfig==((OTConfigurationRef)-1L)) {      fprintf(unit2,"delport: Invalid Configuration for nbp Mapper\n");      return;   }/* Create a synchronous mapper provider */   mref = OTOpenMapperInContext(cfig,0,&oss,NULL);   if (!mref) {      fprintf(unit2,"delport: Invalid NBP Mapper, oss=%d\n",oss);      OTDestroyConfiguration(cfig);      return;   }/* Set a provider to wait or block until function can complete */   oss = OTSetBlocking(mref);   if (oss) {      fprintf(unit2,"delport: NBP Mapper Set Blocking Error, oss=%d\n",oss);      OTCloseProvider(mref);      return;   }/* Remove a previously registered name as specified by its name ID */   oss = OTDeleteNameByID(mref,nameid);   if (oss)      fprintf(unit2,"OTDeleteNameByID Error, oss = %d\n",oss);/* Close a provider of any type */   oss = OTCloseProvider(mref);   if (oss)      fprintf(unit2,"delport: Close NBP Provider Error, oss = %d\n",oss);   return;}static pascal void notifier(void* context, OTEventCode event,   OTResult result, void* cookie) {/* notifier function for asynchronous and completion eventslocal data */   int n, m;   long oss, tryagn = 0;   InetAddress addrb;   TCall call;/* internal mpi common block   epref = array of endpoint references for each participating node   nevents = log of unknown notifier events                          *//* internal common block for non-blocking messages   rwrec = read/write record for asynchronous messages   trash = trash bin for unwanted data   mqueue = message request queue                                    *//* Get reference to endpoint */   n = *(int *)context;/* Check event */L10: switch (event) {      case T_LISTEN: {/* Set TNetbuf for address which is returned */         call.addr.maxlen = 16;         call.addr.buf = (unsigned char *)&addrb;/* Set TNetbuf for options which are returned */         call.opt.maxlen = 0;         call.opt.buf = 0;/* Set TNetbuf for data which is returned */         call.udata.maxlen = 0;         call.udata.buf = 0;/* Listen for an incoming connection request */         oss = OTListen(epref[n],&call);         if (oss)/* Set completion flag to error */            *((int *)context+1) = oss;         else {            m = *((int *)context+1);/* Accept an incoming connection request */            oss = OTAccept(epref[n],epref[m-1],&call);         }         return;      }      case T_CONNECT: {/* Read the status of an asynchronous call to OTConnect */         oss = OTRcvConnect(epref[n],0);/* Set completion flag */         *((int *)context+1) = oss;         return;      }      case T_DISCONNECT: {/* Identify cause of connection rejection and clear event */         oss = OTRcvDisconnect(epref[n],0);/* Set completion flag *//*       *((int *)context+1) = oss; *//* Read pointer to current read record */         m = *((int *)context+2) - 1;/* Set iocompletion flag, if there is a pending read */         if ((m >= 0) && (m < MAXM))            rwrec[m].ioflag = -2;/* Read pointer to current send record */         m = *((int *)context+3) - 1;/* Set iocompletion flag, if there is a pending send */         if ((m >= 0) && (m < MAXM))            rwrec[m].ioflag = -2;         return;      }      case T_DISCONNECTCOMPLETE: {/* Set completion flag *//*       *((int *)context+1) = oss; */         return;      }      case T_ACCEPTCOMPLETE: {         *((int *)context+1) = result;         return;      }      case T_PASSCON: {/* Set completion flag */         *((int *)context+1) = 0;         return;      }      case T_ORDREL: {/* Reset event to complete OTLookErr handling */         if (tryagn)            event = tryagn;/* Clear an incoming orderly disconnect event */         oss = OTRcvOrderlyDisconnect(epref[n]);/* Set completion flag *//*       *((int *)context+1) = oss; *//* Read pointer to current read record */         m = *((int *)context+2) - 1;/* Set iocompletion flag, if there is a pending read */         if ((m >= 0) && (m < MAXM))            rwrec[m].ioflag = -1;/* Read pointer to current send record */         m = *((int *)context+3) - 1;/* Set iocompletion flag, if there is a pending send */         if ((m >= 0) && (m < MAXM))            rwrec[m].ioflag = -1;/* Obtain the current state of an endpoint */         oss = OTGetEndpointState(epref[n]);         if (oss==T_INREL)/* Send a module-specific command to Open Transport protocol module */            oss = OTIoctl(epref[n],I_FLUSH,(void *)FLUSHRW);         break;      }      case kStreamIoctlEvent: {/* Initiate an orderly disconnect */         oss = OTSndOrderlyDisconnect(epref[n]);/* Set completion flag */         *((int *)context+1) = oss;         return;      }      case T_DATA: {         tryagn = 0;/* Read pointer to current read record */         m = *((int *)context+2) - 1;/* Read data sent from a remote peer */         if ((m >= 0) && (m < MAXM)) {/* Obtain the current time stamp */            OTGetTimeStamp(&rwrec[m].ts[1]);L20:        oss = OTRcv(rwrec[m].ref,rwrec[m].buf,rwrec[m].nbytes,                        &rwrec[m].flags);/* Unexpected flag returned */            if (rwrec[m].flags > 1) {               rwrec[m].ioflag = -3;/* Clear pointer to current read record */               *((int *)context+2) = 0;            }/* Process data which arrived */            else if (oss >= 0) {/* Clear more flag */               rwrec[m].flags = 0;/* Clear non-fatal error code */               rwrec[m].nfatal = 0;/* Set actual length received */               rwrec[m].len += oss;/* Check if all the data has arrived */               if (rwrec[m].len < header[m].hdata[3]) {/* Incomplete message */                  if (rwrec[m].nbytes > oss) {/* Readjust buffer pointer */                     rwrec[m].buf = (void *)(((unsigned char *)rwrec[m].buf) + oss);                     rwrec[m].nbytes -= oss;                     if (rwrec[m].len >= 0)                        rwrec[m].ioflag += 1;                  }/* Header is received, readjust parameters to receive data */                  else if (rwrec[m].ioflag==1) {                     rwrec[m].buf = rwrec[m].sbuf;                     rwrec[m].nbytes = imin(header[m].hdata[3],rwrec[m].sln);                     rwrec[m].ioflag = 2;                  }/* Data is received and buffer is full */                  else {                     rwrec[m].buf = &trash;                     rwrec[m].nbytes = 1024;                  }                  goto L20;               }/* Message complete */               else {/* Obtain the current time stamp */                  OTGetTimeStamp(&rwrec[m].ts[1]);/* Set iocompletion flag */                  rwrec[m].ioflag = 0;/* Get next message if messages are queued */                  if (rwrec[m].nextm > 0) {                     m = rwrec[m].nextm;                     if (m==mqueue[n][0])                        mqueue[n][0] = 0;                     *((int *)context+2) = m;                     m -= 1;                     goto L20;                  }/* Clear pointer to current send record */                  else                     *((int *)context+2) = 0;               }            }/* Check for errors */            else {/* Quit if no data is available */               if (oss==kOTNoDataErr)                  return;/* Determine cause of a kOTLookErr */               else if (oss==kOTLookErr) {                  event = OTLook(rwrec[m].ref);                  if ((event==T_GODATA) || (event==T_ORDREL)) {                     tryagn = T_DATA;                     break;                  }/* Store unprocessed event returned by OTLookErr */                  else                     nevents[n] = event;               }/* Store non-fatal error code */               else if (oss==kENOMEMErr) {                  rwrec[m].nfatal = oss;                  return;               }/* Set iocompletion flag to error */               rwrec[m].ioflag = oss;               *((int *)context+2) = 0;            }         }         return;      }      case T_GODATA: {/* Read pointer to current send record */         m = *((int *)context+3) - 1;/* Reset event to complete OTLookErr handling */         if (tryagn)            event = tryagn;/* Send data to a remote peer */         if ((m >= 0) && (m < MAXM)) {/* Obtain the current time stamp */            OTGetTimeStamp(&rwrec[m].ts[1]);L30:        oss = OTSnd(rwrec[m].ref,rwrec[m].buf,rwrec[m].nbytes,                        rwrec[m].flags);/* Process data which has been sent */            if (oss >= 0) {/* Clear non-fatal error code */               rwrec[m].nfatal = 0;/* Set actual length sent */               rwrec[m].len += oss;/* Check for incomplete header */               if (rwrec[m].len < 0) {                  header[m].first.fData =                      (void *)(((unsigned char *)header[m].first.fData) + oss);                  header[m].first.fLen -= oss;                  goto L30;               }/* Check for incomplete data */               else if (rwrec[m].sln > rwrec[m].len) {/* Header is sent, readjust parameters to send data */                  if (rwrec[m].ioflag==1) {                     rwrec[m].buf = rwrec[m].sbuf;                     rwrec[m].nbytes = rwrec[m].sln;                     oss -= header[m].first.fLen;                  }/* Readjust buffer pointer */                  rwrec[m].buf = (void *)(((unsigned char *)rwrec[m].buf) + oss);                  rwrec[m].nbytes -= oss;                  rwrec[m].ioflag += 1;                  goto L30;               }/* Data is sent */               else {/* Obtain the current time stamp */                  OTGetTimeStamp(&rwrec[m].ts[1]);/* Set iocompletion flag */                  rwrec[m].ioflag = 0;/* Get next message if messages are queued */                  if (rwrec[m].nextm > 0) {                     m = rwrec[m].nextm;                     if (m==mqueue[n][1])                        mqueue[n][1] = 0;                     *((int *)context+3) = m;                     m -= 1;                     goto L30;                  }/* Clear pointer to current send record */                  else                     *((int *)context+3) = 0;               }            }/* Check for errors */            else {/* Quit if no data can be sent */               if (oss==kOTFlowErr)                  break;/* Determine cause of a kOTLookErr */               else if (oss==kOTLookErr) {                  event = OTLook(rwrec[m].ref);/* Store unprocessed event returned by OTLookErr */                  nevents[n] = event;               }/* Store non-fatal error code */               else if (oss==kENOMEMErr) {                  rwrec[m].nfatal = oss;                  break;               }/* Set iocompletion flag to error */               rwrec[m].ioflag = oss;               *((int *)context+3) = 0;            }         }         break;      }      default: {/* unknown event */         nevents[n] = event;         return;      }   }   if (tryagn)      goto L10;   return;}long otpinit(int np, TBind *reqad, TBind *repad) {/* this subroutine initializes an Open Transport provider for   index np, using address specified in reqad.  The cfig0   OTConfiguration template is assumed to be already created   provider is left in asynchronous, blocking mode   np = index to endpoint reference array   reqad = address to which endpoint is to be bound   repad = address to which endpoint is actually bound   returns OSStatus indicator   input: np, reqadlocal data                                                       */   int i;   long oss, value;   OTConfigurationRef cfig;   TEndpointInfo epinfo;   InetAddress *addrn;/* internal mpi common block   cfig0 = OTConfiguration structure template   epref = array of endpoint references for each participating node   ioc = array of context pointers for notifier function                  */   oss = 0;/* Copy an OTConfiguration structure */   cfig = OTCloneConfiguration(cfig0);/* Create a synchronous endpoint provider */   epref[np] = OTOpenEndpointInContext(cfig,0,&epinfo,&oss,NULL);   if (!epref[np]) {      fprintf(unit2,"Invalid Endpoint, oss=%d\n",oss);      OTDestroyConfiguration(cfig);;      return oss;   }/* Set a provider to wait or block until function can complete */   oss = OTSetBlocking(epref[np]);   if (oss) {      fprintf(unit2,"Endpoint Set Blocking Error, oss = %d\n",oss);      return oss;   }/* set TCP_NODELAY option */   value = 1;   oss = setopts(epref[np],INET_TCP,TCP_NODELAY,&value);   if (oss)      fprintf(unit2,"TCP_NODELAY OTOptionManagement Error, oss = %d\n",oss);   else if (!value)      fprintf(unit2,"Info: TCP_NODELAY was not set\n");/* Install a notifier function */   oss = OTInstallNotifier(epref[np],notifierUPP,&ioc[np]);   if (oss) {      fprintf(unit2,"OTInstall Notifier Error, oss = %d\n",oss);      return oss;   }   i = 0;   addrn = (InetAddress *)reqad->addr.buf;/* Assign an address to an endpoint */L10: oss = OTBind(epref[np],reqad,repad);   if (oss) {      if ((addrn->fPort) && (i < 16)) {         addrn->fPort += 1;         i += 1;         goto L10;      }      fprintf(unit2,"OTBind Error, oss = %d\n",oss);      if (oss==kOTNoAddressErr)         fprintf(unit2,"unable to allocate address\n");      return oss;   }/* Pass processor epref index and iocompletion to notifier */   ioc[np][0] = np;   ioc[np][1] = 1;/* Clear read and send record pointers */   ioc[np][2] = 0;   ioc[np][3] = 0;/* Set a provider to asynchronous mode */   oss = OTSetAsynchronous(epref[np]);   return oss;}long setopts(EndpointRef epref, unsigned long level, unsigned long name, long *value) {/* This function sets value of optionlocal data */   long oss;   TOption option;   TOptMgmt req, ret;/* Set option structure */   option.len = 20;   option.level = level;   option.name = name;   option.status = 0;   option.value[0] = *value;/* Set OptMgmt request structure */   req.opt.len = 20;   req.opt.buf = (unsigned char *)&option;   req.flags = T_NEGOTIATE;/* Set OptMgmt reply structure */   ret.opt.maxlen = 20;   ret.opt.buf = (unsigned char *)&option;/* Determine an endpoint's option values or change the values */   oss = OTOptionManagement(epref,&req,&ret);   if (!oss) {      if ((option.status==T_SUCCESS))         *value = option.value[0];      else {         oss = option.status;         if (oss==T_NOTSUPPORT)            fprintf(unit2,"Option Not Supported\n");      }   }   else {      if (oss==kOTBufferOverflowErr)         fprintf(unit2,"Option reply buffer is too small\n");   }   return oss;}int ioresult(int *pblock) {/* this function returns ioResult for asynchronous procedures   input: pblock                                              */   return pblock[1];}int checkesc(long stk) {/* this procedure allows user to abort a procedure by checking for   escape, Cmd-. or Ctrl-C keystrokes.  Calling EventAvail also   permits an idle procedure to time-share and checks for Quit Events   returns true if an escape event occurred.   recent keyboard events not processed are not removed from event queue   stk = maximum number of sleepTicks (sixtieths of a second) that   application agrees to relinquish the processor if no events are    pending for it.   input: stklocal data                                                   *//* myEventMask looks for mouse, keyboard, and quit events    */   short myEventMask = 1086;   EventRecord event;   int key, checkesc = 0, nvp;   WindowPtr which;   static OTTimeStamp times;/* internal common block for message window   cpptr = pointer to window structure   crect = current drag region                            *//* if monitor window is open, look for update events also */   if (cpptr)      myEventMask += 64;/* get an event without removing it from the queue */   if (EventAvail(myEventMask,&event)) {      if ((event.what==keyDown) || (event.what==autoKey)) {/* check for escape key */         key = event.message - 256*(event.message/256);         if (key==27)            checkesc = 1;/* check for Cmd-. */         else if (key==46) {            if ((event.modifiers/256) != (2*(event.modifiers/512)))               checkesc = 1;         }/* check for Ctrl-C */         else if (key==3)            checkesc = 1;/* remove processed or keyboard event more than 3 seconds old */         if (checkesc || ((TickCount()-event.when) > 180))/* remove next available event */            GetNextEvent(myEventMask,&event);      }/* check for 'QuitApplication' Apple Event */      else if (event.what==kHighLevelEvent) {/* remove high level events more than 5 seconds old */         if ((TickCount()-event.when) > 300)/* remove next available event */            GetNextEvent(myEventMask,&event);         if ((event.where.v=='qu') && (event.where.h=='it')) {            fprintf(unit2,"Quit Application Apple Event received\n");            checkesc = 1;         }      }/* check for update events */      else if (event.what==updateEvt) {/* get window pointer */         if (cpptr==(WindowPtr)event.message) {/* remove next available event */            GetNextEvent(myEventMask,&event);/* signal start of window update */            BeginUpdate(cpptr);            key = MPI_Comm_size(MPI_COMM_WORLD,&nvp);            messwin(nvp);/* signal end of update after BeginUpdate */            EndUpdate(cpptr);         }      }/* check for drag window event */      else if (event.what==mouseDown) {/* see which window part, including menu bar, is at a point */         if (FindWindow(event.where,&which)==4) {            if (cpptr==which) {/* remove next available event */               GetNextEvent(myEventMask,&event);/* track the mouse and move a window */               DragWindow(cpptr,event.where,&crect);            }         }      }   }/* yield time when time slice since last yield > 1 second */   if (stk==0) {/* calculate time elapsed in milliseconds */      if (OTElapsedMilliseconds(&times) > 1000) {/* receive null event from event manager to relinquish the processor */         WaitNextEvent(0,&event,1,0);/* Obtain the current time stamp */         OTGetTimeStamp(&times);      }   }/* yield time if requested */   else {/* receive null event from event manager to relinquish the processor */      WaitNextEvent(0,&event,stk,0);/* Obtain the current time stamp */      OTGetTimeStamp(&times);   }   return checkesc;}int MPI_Finalize(void) {/* terminate MPI execution environmentlocal data                             */   int ierror, i;   long state, oss;   OTTimeStamp ptime;/* internal mpi common block   nproc = number of real or virtual processors obtained   cfig0 = OTConfiguration structure template   epref = array of endpoint references for each participating node   nevents = log of unknown notifier events   mapcomm = communicator map                                            *//* internal common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages   curreq = request record for transmission parameters                   */   ierror = 0;/* MPI already finalized */   if (nproc < 0) {      ierror = 1;      return ierror;   }   if (monitor==2)      fprintf(unit2,"MPI_Finalize started\n");/* Dispose of an OTConfiguration structure */   OTDestroyConfiguration(cfig0);/* Flush endpoint providers */   for (i = 0; i <= MAXS; i++) {      if (epref[i]) {/* Obtain the current state of an endpoint */         state = OTGetEndpointState(epref[i]);         if (state==T_DATAXFER)/* Send a module-specific command to Open Transport protocol module */            oss = OTIoctl(epref[i],I_FLUSH,(void *)FLUSHRW);      }   }/* Obtain the current time stamp */   OTGetTimeStamp(&ptime);/* Disconnect endpoints with orderly disconnect */   for (i = 0; i <= MAXS; i++) {      if (epref[i]) {/* Wait 5 seconds for endpoints to acknowledge disconnect */L20:     state = OTGetEndpointState(epref[i]);         if (state > T_IDLE) {/* Calculate time elapsed in milliseconds */            if (OTElapsedMilliseconds(&ptime) < 5000)               goto L20;            else {               fprintf(unit2,"OrderlyDisconnect Timeout: i,state=%d,%d\n",                       i,state);/* Tear down an open connection (abortive disconnect) */               oss = OTSndDisconnect(epref[i],0);               if (oss) {                  fprintf(unit2,"OTSndDisconnect Error, i,oss=%d,%d\n",i,oss);                  if (oss==kOTOutStateErr)                     fprintf(unit2,"Endpoint not in an appropriate state=%d\n",                             OTGetEndpointState(epref[i]));               }            }         }      }   }/* Obtain the current time stamp */   OTGetTimeStamp(&ptime);/* Unbind and close providers */   for (i = 0; i <= MAXS; i++) {      if (epref[i]) {/* Wait another 5 seconds for endpoints to acknowledge disconnect */L40:     state = OTGetEndpointState(epref[i]);         if (state > T_IDLE) {/* Calculate time elapsed in milliseconds */            if (OTElapsedMilliseconds(&ptime) < 5000)               goto L40;            else               fprintf(unit2,"Disconnect Timeout: i,state=%d,%d\n",                       i,state);         }/* Set a provider to synchronous mode */         oss = OTSetSynchronous(epref[i]);/* Dissociate an endpoint from its address */         oss = OTUnbind(epref[i]);         if (oss) {            fprintf(unit2,"Unbind Endpoint Error, i, oss = %d,%d\n",i,oss);            if (oss==kOTOutStateErr)               fprintf(unit2,"Endpoint not in an appropriate state=%d\n",                       OTGetEndpointState(epref[i]));         }/* Close a provider of any type */         oss = OTCloseProvider(epref[i]);         if (oss) {            fprintf(unit2,"Close Endpoint Error, i, oss = %d,%d\n",i,oss);            ierror = oss;         }      }   }/* Dispose of Univeral Proc Ptr */   DisposeOTNotifyUPP(notifierUPP);   notifierUPP = 0;/* Unregister adsp endpoint created for puppy */   if (LDM)      delport();/* Unregister your application connection to Open Transport */   CloseOpenTransportInContext(NULL);/* Write out any unknown notifier events */   for (i = 0; i <= MAXS; i++) {      if (nevents[i])         fprintf(unit2,"Unknown notifier event, endpoint=%d,%d\n",nevents[i],i);   }/* Close window for showing MPI message status */   if (monitor > 0) {      logmess(0,0,-1,0,0);      delmess();   }/* Nullify nproc */   nproc = -1;/* Nullify communicator mappings */   for (i = 0; i < MAXC; i++) {      mapcomm[i][MAXS] = 0;   }/* Nullify endpoint references and unknown notifier events */   for (i = 0; i <= MAXS; i++) {      epref[i] = 0;      nevents[i] = 0;   }/* check if any messages remain outstanding */   state = 0;   for (i = 0; i < MAXM; i++) {      if (curreq[i][0])         state += 1;   }   if (state > 0) {      fprintf(unit2,"%d message(s) never cleared\n",state);      for (i = 0; i < MAXM; i++) {         if (curreq[i][0]) {            if (curreq[i][0]==(-1))              fprintf(unit2," transmission mode = send\n");            else if (curreq[i][0]==1)               fprintf(unit2," transmission mode = receive\n");            fprintf(unit2," destination/source = %d\n",curreq[i][1]);            fprintf(unit2," communicator = %d\n",curreq[i][2]);            fprintf(unit2," tag = %d\n",curreq[i][3]);            fprintf(unit2," datatype = %d\n",curreq[i][4]);            fprintf(unit2,"\n");         }      }   }   if (monitor==2)      fprintf(unit2,"MPI_Finalize complete\n");/* Delete file if empty */   if (!fseek(unit2,0,SEEK_END)) {      i = ftell(unit2);      fclose(unit2);      if (!i)         remove("MPIerrs");   }   return ierror;}int MPI_Send(void* buf, int count, MPI_Datatype datatype, int dest,             int tag, MPI_Comm comm) {/* blocking standard mode send   buf = initial address of send buffer   count = number of entries to send   datatype = datatype of each entry   dest = rank of destination   tag = message tag   comm = communicator   input: buf, count, datatype, dest, tag, commlocal data                                                       */   int ierror;   MPI_Request request;   MPI_Status status;   ierror = MPI_Isend(buf,count,datatype,dest,tag,comm,&request);   ierror = MPI_Wait(&request,&status);   return ierror;} int MPI_Recv(void* buf, int count, MPI_Datatype datatype, int source,             int tag, MPI_Comm comm, MPI_Status *status) {/* blocking receive   buf = initial address of receive buffer   count = maximum number of entries to receive   datatype = datatype of each entry   source = rank of source   tag = message tag   comm = communicator   status = return status   input: count, datatype, source, tag, comm   output: buf, statuslocal data                                                       */   int ierror;   MPI_Request request;   ierror = MPI_Irecv(buf,count,datatype,source,tag,comm,&request);   ierror = MPI_Wait(&request,status);   return ierror;}int MPI_Isend(void* buf, int count, MPI_Datatype datatype, int dest,              int tag, MPI_Comm comm, MPI_Request *request) {/* start a non-blocking send   buf = initial address of send buffer   count = number of entries to send   datatype = datatype of each entry   dest = rank of destination   tag = message tag   comm = communicator   request = request handle   input: buf, count, datatype, dest, tag, comm   output: requestlocal data                                                           */   int ierror, np, longw, i;   long response;/* internal mpi common block   nproc = number of real or virtual processors obtained   idproc = processor id   epref = array of endpoint references for each participating node   ioc = array of context pointers for notifier function   mapcomm = communicator map                                       *//* internal common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages   curreq = request record for transmission parameters   header = message envelope   rwrec = read/write record for asynchronous messages   mqueue = message request queue                                     */   ierror = 0;   if (dest==MPI_PROC_NULL) {      *request = MPI_REQUEST_NULL;      return ierror;   }/* find space for record */   i = -1;L10: i += 1;   if (i >= MAXM) {      fprintf(unit2,"too many sends waiting, dest, tag = %d,%d,\n",              dest,tag);      *request = MPI_REQUEST_NULL;      ierror = 14;      writerrs("MPI_Isend: ",ierror);      return ierror;   }   else if (curreq[i][0])      goto L10;/* check for error conditions *//* MPI not initialized        */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm < 0) || (comm >= MAXC))      ierror = 2;/* invalid count */   else if (count < 0)      ierror = 3;/* invalid destination */   else if ((dest < 0) || (dest >= nproc)) {      fprintf(unit2,"destination = %d\n",dest);      ierror = 4;   }/* invalid tag */   else if (tag < (-1))      ierror = 6;/* communicator errors */   else {      longw = mapcomm[comm][MAXS];      np = mapcomm[comm][dest];/* communicator not mapped */      if ((longw <= 0) || (longw > nproc))         ierror = 2;/* invalid destination */      else if ((dest < 0) || (dest >= longw)) {         fprintf(unit2,"destination = %d\n",dest);         ierror = 4;      }/* invalid mapping */      else if ((np < 0) || (np >= nproc)) {         fprintf(unit2,"Invalid mapping, destination, node = %d,%d\n",dest,np);         ierror = 2;      }   }/* handle errors */   if (ierror) {      writerrs("MPI_Isend: ",ierror);      return ierror;   }/* Create header *//* OTData structure for header */   header[i].first.fNext = &header[i].second;   header[i].first.fData = &header[i].hdata[0];   header[i].first.fLen = 16;/* Save communicator */   header[i].hdata[0] = comm;/* Save tag */   header[i].hdata[1] = tag;/* Save datatype */   header[i].hdata[2] = datatype;/* Set destination id for selfsends */   if (idproc==np)      np = MAXS;/* Set endpoint reference pointer */   rwrec[i].ref = epref[np];/* Reset iocompletion flag */   rwrec[i].ioflag = 1;/* Set pointer to header */   rwrec[i].buf = (void *)&header[i];/* Set buffer length for header */   rwrec[i].nbytes = kNetbufDataIsOTData;/* Find buffer length for data */   if ((datatype==MPI_INT) || (datatype==MPI_FLOAT))      longw = 4*count;   else if (datatype==MPI_DOUBLE)      longw = 8*count;   else if (datatype==MPI_BYTE)      longw = count;   else if ((datatype==MPI_2INT) || (datatype==MPI_FLOAT_INT))       longw = 8*count;   else if (datatype==MPI_DOUBLE_INT)      longw = 16*count;/* Invalid datatype */   else {      ierror = 7;      writerrs("MPI_Isend: ",ierror);      return ierror;   }/* Set pointer to data buffer */   rwrec[i].sbuf = buf;/* Set buffer lengths for data */   rwrec[i].sln = longw;   rwrec[i].len = -header[i].first.fLen;/* Clear more flag */   rwrec[i].flags = 0;/* Clear next message flag */   rwrec[i].nextm = 0;/* Clear non-fatal error code */   rwrec[i].nfatal = 0;/* OTData structure for data */;   header[i].second.fNext = 0;   header[i].second.fData = rwrec[i].sbuf;   header[i].second.fLen = longw;/* Save length */   header[i].hdata[3] = longw;/* Obtain the current time stamp */   OTGetTimeStamp(&rwrec[i].ts[0]);/* Limit notifications that can be sent to notifier */   OTEnterNotifier(epref[np]);/* Append this message to send queue if necessary */   if (ioc[np][3] > 0) {      if (mqueue[np][1] > 0)         rwrec[mqueue[np][1]-1].nextm = i + 1;      else         rwrec[ioc[np][3]-1].nextm = i + 1;      mqueue[np][1] = i + 1;/* Obtain the current time stamp */      OTGetTimeStamp(&rwrec[i].ts[1]);      goto L30;   }/* First send 4 word header, then data */      sndmsgf(i,np);      response = ioresult((int *)&rwrec[i]);/* Set pointer to current send record */      if (response > 0)         ioc[np][3] = i + 1;/* Set iocompletion flag to error */      else if (response < 0)         ierror = response;/* Allow Open Transport to resume sending events */L30: OTLeaveNotifier(epref[np]);/* Handle read and write errors */   if (ierror) {/* Write out readwrite record */      rwstat(i,unit2);      wqueue(unit2);      for (i = 0; i < MAXM; i++) {         if (curreq[i][0] != 0)            rwstat(i,unit2);      }      writerrs("MPI_ISend: ",ierror);   }/* Find actual destination */   if (np==MAXS)      np = idproc;/* log MPI message state change and display status */   if (monitor > 0)       logmess(np,1,rwrec[i].sln,0,tag);/* save transmission mode as send */   curreq[i][0] = -1;/* save destination/source id */   curreq[i][1] = np;/* save communicator */   curreq[i][2] = comm;/* save tag */   curreq[i][3] = tag;/* save datatype */   curreq[i][4] = datatype;/* assign request handle */   *request = i;   return ierror;}int MPI_Irecv(void* buf, int count, MPI_Datatype datatype, int source,              int tag, MPI_Comm comm, MPI_Request *request) {/* begin a non-blocking receive   buf = initial address of receive buffer   count = maximum number of entries to receive   datatype = datatype of each entry   source = rank of source   tag = message tag   comm = communicator   request = request handle   input: count, datatype, source, tag, comm   output: buf, requestlocal data                                                            */   int ierror, np, longw, i;   long response;/* internal mpi common block   nproc = number of real or virtual processors obtained   epref = array of endpoint references for each participating node   ioc = array of context pointers for notifier function   mapcomm = communicator map                                         *//* internal common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages   curreq = request record for transmission parameters   header = message envelope   rwrec = read/write record for asynchronous messages   mqueue = message request queue                                     */   ierror = 0;   if (source==MPI_PROC_NULL) {      *request = MPI_REQUEST_NULL;      return ierror;   }/* find space for record */   i = -1;L10: i += 1;   if (i >= MAXM) {      fprintf(unit2,"too many receives waiting, source, tag = %d,%d,\n",              source,tag);      *request = MPI_REQUEST_NULL;;      ierror = 15;      writerrs("MPI_Irecv: ",ierror);      return ierror;   }   else if (curreq[i][0])      goto L10;/* check for error conditions *//* MPI not initialized        */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm < 0) || (comm >= MAXC))      ierror = 2;/* invalid count */   else if (count < 0)      ierror = 3;/* invalid source */   else if ((source < 0) || (source >= nproc)) {      if (source==MPI_ANY_SOURCE)         fprintf(unit2,"MPI_ANY_SOURCE not supported\n");      else         fprintf(unit2,"source = %d\n",source);      ierror = 5;   }/* invalid tag */   else if (tag < (-1))      ierror = 6;/* communicator errors */   else {      longw = mapcomm[comm][MAXS];      np = mapcomm[comm][source];/* communicator not mapped */      if ((longw <= 0) || (longw > nproc))         ierror = 2;/* invalid source */      else if ((source < 0) || (source >= longw)) {         fprintf(unit2,"source = %d\n",source);         ierror = 4;      }/* invalid mapping */      else if ((np < 0) || (np >= nproc)) {         fprintf(unit2,"Invalid mapping, source, node = %d,%d\n",source,np);         ierror = 2;      }   }/* handle errors */   if (ierror) {      writerrs("MPI_Irecv: ",ierror);      return ierror;   }/* Set endpoint reference pointer */   rwrec[i].ref = epref[np];/* Reset iocompletion flag for receive */   rwrec[i].ioflag = 1;/* Set pointer to header */   rwrec[i].buf = (void *)&header[i].hdata[0];/* Set buffer length for header */   rwrec[i].nbytes = 16;/* Set buffer length for data */   if ((datatype==MPI_INT) || (datatype==MPI_FLOAT))      longw = 4*count;   else if (datatype==MPI_DOUBLE)      longw = 8*count;   else if (datatype==MPI_BYTE)      longw = count;   else if ((datatype==MPI_2INT) || (datatype==MPI_FLOAT_INT))       longw = 8*count;   else if (datatype==MPI_DOUBLE_INT)      longw = 16*count;/* Invalid datatype */   else {      ierror = 7;      writerrs("MPI_Irecv: ",ierror);      return ierror;   }  /* Set pointer to data buffer */   rwrec[i].sbuf = buf;/* Set buffer lengths */   rwrec[i].sln = longw;   rwrec[i].len = -rwrec[i].nbytes;/* Clear more flag */   rwrec[i].flags = 0;/* Clear next message flag */   rwrec[i].nextm = 0;/* Clear non-fatal error code */   rwrec[i].nfatal = 0;/* Clear length */   header[i].hdata[3] = 0;/* Obtain the current time stamp */   OTGetTimeStamp(&rwrec[i].ts[0]);/* Limit notifications that can be sent to notifier */   OTEnterNotifier(epref[np]);/* Append this message to receive queue if necessary */   if (ioc[np][2] > 0) {      if (mqueue[np][0] > 0)         rwrec[mqueue[np][0]-1].nextm = i + 1;      else         rwrec[ioc[np][2]-1].nextm = i + 1;      mqueue[np][0] = i + 1;/* Obtain the current time stamp */      OTGetTimeStamp(&rwrec[i].ts[1]);      goto L40;   }/* First receive 4 word header, then data */      rcvmsgf(i,np);      response = ioresult((int *)&rwrec[i]);/* Set pointer to current receive record */      if (response > 0)         ioc[np][2] = i + 1;/* Set iocompletion flag to error */      else if (response < 0)         ierror = response;/* Allow Open Transport to resume sending events */L40: OTLeaveNotifier(epref[np]);/* Handle read and write errors */   if (ierror) {/* Write out readwrite record */      rwstat(i,unit2);      wqueue(unit2);      for (i = 0; i < MAXM; i++) {         if (curreq[i][0] != 0)            rwstat(i,unit2);      }      writerrs("MPI_IRecv: ",ierror);   }/* log MPI message state change and display status */   if (monitor > 0)       logmess(np,2,rwrec[i].sln,0,tag);/* save transmission mode as receive */   curreq[i][0] = 1;/* save destination/source id */   curreq[i][1] = np;/* save communicator */   curreq[i][2] = comm;/* save tag */   curreq[i][3] = tag;/* save datatype */   curreq[i][4] = datatype;/* assign request handle */   *request = i;   return ierror;}int MPI_Test(MPI_Request *request, int *flag, MPI_Status *status) {/* check to see if a nonblocking send or receive operation has completed   request = request handle   flag = true if operation completed   status = status object   input: request   output: request, flag, statuslocal data                                                            */   int ierror, i, dest, source, slen, tag, rlen, rtag, nerr, j;   float ts;   MPI_Comm comm, rcomm;   MPI_Datatype datatype, rdatat;   OTTimeStamp delta;/* mstime = maximum time (msec) to wait for message to start arriving   mptime = maximum time (msec) to wait for next part of message      */   static int mstime = 300000, mptime = 10000;/* internal mpi common block   nproc = number of real or virtual processors obtained   ioc = array of context pointers for notifier function            *//* internal common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages   curreq = request record for transmission parameters   header = message envelope   rwrec = read/write record for asynchronous messages                   */   ierror = 0;/* check for error conditions */   i = *request;/* MPI not initialized */   if (nproc <= 0)      ierror = 1;/* null request */   else if (*request < 0) {      *flag = 1;      return 0;   }/* invalid request handle */   else if (i >= MAXM)      ierror = 16;   else if (curreq[i][0]==0)      ierror = 16;/* handle errors */   if (ierror) {      status->error = ierror;      writerrs("MPI_Test: ",ierror);      return ierror;   }/* set status to empty */   status->source = -1;   status->tag = -1;   status->error = ierror;   status->len = 0;   status->type = 0;   *flag = 0;/* Check if data read or write has completed */   if (ioresult((int *)&rwrec[i]) > 0) {      if (checkesc(0)) {         if (curreq[i][0] < 0)            fprintf(unit2,"Send killed,dest,tag=%d,%d\n",                    curreq[i][1],curreq[i][3]);         else            fprintf(unit2,"Receive killed,source,tag=%d,%d\n",                    curreq[i][1],curreq[i][3]);         ierror = -9;         writerrs("MPI_Test: ",ierror);         return ierror;      }/* Check Timeout */      else {/* Limit notifications that can be sent to notifier */         OTEnterNotifier(rwrec[i].ref);/* Calculate time elapsed in milliseconds */         nerr = OTElapsedMilliseconds(&rwrec[i].ts[1]);/* Retry Send or Receive */         if ((nerr < mptime) && (rwrec[i].nfatal != kENOMEMErr)) {/* Allow Open Transport to resume sending events */            OTLeaveNotifier(rwrec[i].ref);            return ierror;         }/* Check if message arrived during checkesc */         nerr = ioresult((int *)&rwrec[i]);         if (nerr <= 0) {            fprintf(unit2,"Info: message arrived during checkesc\n");            *flag = 1;            goto L20;         }/* Check if any other messages need service */         for (j = 0; j < MAXM; j++) {            if ((j != i) && (curreq[j][0] < 0)) {/* Limit notifications that can be sent to notifier */               if (rwrec[i].ref != rwrec[j].ref)                  OTEnterNotifier(rwrec[j].ref);/* Check if out of memory flag is set and message is incomplete */               if (rwrec[j].nfatal==kENOMEMErr) {                  if (ioresult((int *)&rwrec[j]) > 0) {                     dest = curreq[j][1];                     fprintf(unit2,"send endpt %d out of memory\n",dest);                     if (idproc==dest)                        dest = MAXS;/* Attempt to send next block of data */                     sndmsgf(j,dest);                     fprintf(unit2,"Info: request, response=%d,%d",j,                             ioresult((int *)&rwrec[j]));                  }               }/* Allow Open Transport to resume sending events */               if (rwrec[i].ref != rwrec[j].ref)                  OTLeaveNotifier(rwrec[j].ref);            }            else if ((j != i) && (curreq[j][0] > 0)) {/* Limit notifications that can be sent to notifier */               if (rwrec[i].ref != rwrec[j].ref)                  OTEnterNotifier(rwrec[j].ref);/* Check if out of memory flag is set and message is incomplete */               if (rwrec[j].nfatal==kENOMEMErr) {                  if (ioresult((int *)&rwrec[j]) > 0) {                     source = curreq[j][1];                     fprintf(unit2,"recv endpt %d out of memory\n",source);/* Attempt to receive next block of data */                     rcvmsgf(j,source);                     fprintf(unit2,"Info: request, response=%d,%d",j,                            ioresult((int *)&rwrec[j]));                  }               }/* Allow Open Transport to resume sending events */               if (rwrec[i].ref != rwrec[j].ref)                  OTLeaveNotifier(rwrec[j].ref);            }         }/* Try to determine cause of Timeout in Send */         if (curreq[i][0] < 0) {            dest = curreq[i][1];            if (rwrec[i].nfatal==kENOMEMErr)               fprintf(unit2,"OT Temporarily out of Memory\n");            else {               ts = .001*(float) OTElapsedMilliseconds(&rwrec[i].ts[0]);               fprintf(unit2,"Send Timeout, %f sec, Retrying...\n",ts);            }/* Debug information */            fprintf(unit2,"destination=%d,size=%d,tag=%d\n",                       dest,rwrec[i].sln,curreq[i][3]);            if (idproc==dest)               dest = MAXS;/* Attempt to send next block of data */            sndmsgf(i,dest);            nerr = ioresult((int *)&rwrec[i]);/* Non-fatal errors */            if (rwrec[i].nfatal) {               if (rwrec[i].nfatal==kOTFlowErr)                  fprintf(unit2,"Flow Control prevents sending data\n");/* Do not wait more than 5 minutes for message to start sending */               if (OTElapsedMilliseconds(&rwrec[i].ts[0]) >= mstime) {                  nerr = rwrec[i].nfatal;                  if (nerr==kENOMEMErr)                     fprintf(unit2,"Open Transport has run out of Memory\n");                  fprintf(unit2,"OTSnd Retry failed\n");                  ierror = nerr;                  ioc[dest][3] = 0;                  *flag = 1;               }            }/* Fatal errors */            else if (nerr < 0) {               ierror = nerr;               *flag = 1;            }/* Data successfully sent */            else {/* Debug information */               fprintf(unit2,"data block sent, current total = %d\n",                       rwrec[i].len);               if (!nerr)                  *flag = 1;            }         }/* Try to determine cause of Timeout in Receive */         else {            source = curreq[i][1];            if (rwrec[i].nfatal==kENOMEMErr)               fprintf(unit2,"OT Temporarily out of Memory\n");            else {               ts = .001*(float) OTElapsedMilliseconds(&rwrec[i].ts[0]);               fprintf(unit2,"Receive Timeout, %f sec, Retrying...\n",ts);            }/* Debug information */            fprintf(unit2,"source=%d,size=%d,tag=%d\n",                       source,rwrec[i].sln,curreq[i][3]);/* Attempt to send next block of data */            rcvmsgf(i,source);            nerr = ioresult((int *)&rwrec[i]);/* Non-fatal errors */            if (rwrec[i].nfatal) {               if (rwrec[i].nfatal==kOTFlowErr)                  fprintf(unit2,"Flow Control prevents accepting data\n");               if (rwrec[i].nfatal==kOTNoDataErr)                  fprintf(unit2,"No data is currently available\n");/* Do not wait more than 5 minutes for message to start sending */               if (OTElapsedMilliseconds(&rwrec[i].ts[0]) >= mstime) {                  nerr = rwrec[i].nfatal;                  if (nerr==kENOMEMErr)                     fprintf(unit2,"Open Transport has run out of Memory\n");                  fprintf(unit2,"OTRcv Retry failed\n");                  ierror = nerr;                  ioc[source][2] = 0;                  *flag = 1;               }            }/* Fatal errors */            else if (nerr < 0) {               ierror = nerr;               *flag = 1;            }/* Data successfully received */            else {/* Debug information */               fprintf(unit2,"data block received, current total = %d\n",                       rwrec[i].len);               if (!nerr)                  *flag = 1;            }         }/* Allow Open Transport to resume sending events */L20:     OTLeaveNotifier(rwrec[i].ref);         if (!(*flag))            return ierror;      }   }/* Data read or write has completed */   else {      nerr = ioresult((int *)&rwrec[i]);      *flag = 1;   }/* Get requested length */   slen = rwrec[i].sln;/* Get actual length */   rlen = rwrec[i].len;/* Read current request record */   tag = curreq[i][3];/* Define length for MPI_Get_count */   status->len = rlen;/* Check for send errors */   if (curreq[i][0] < 0) {      dest = curreq[i][1];/* Define type for MPI_Get_count */      status->type = curreq[i][4];/* Check for write errors */      if (nerr < 0) {         if (!ierror) {            fprintf(unit2,"OTSnd Error, nerr, dest, tag = %d,%d,%d\n",                    nerr,dest,tag);            if (nerr==kOTOutStateErr)               fprintf(unit2,"Endpoint not in an appropriate state\n");            else if (nerr==kENOMEMErr)               fprintf(unit2,"Open Transport has run out of memory\n");            ierror = nerr;         }      }      else if (rlen != slen) {         fprintf(unit2,"Send Length Error,dest,tag,requested/actual length=%d,%d,%d,%d\n",                 dest,tag,slen,rlen);         ierror = 8;      }/* log MPI message state change and display status */      if (monitor > 0) {         if (checkesc(0)) {            ierror = -9;            writerrs("MPI_Test: ",ierror);            return ierror;         }         else if (!ierror) {/* Subtract one timestamp value from another */            OTSubtractTimeStamps(&delta,&rwrec[i].ts[0],&rwrec[i].ts[1]);/* Convert difference between time steps into microseconds */            nerr = OTTimeStampInMicroseconds(&delta);            logmess(dest,-1,rlen,nerr,tag);         }      }      goto L30;   }/* Read current request record */   source = curreq[i][1];   comm = curreq[i][2];   datatype = curreq[i][4];/* Read header *//* Get received tag from header */   rtag = header[i].hdata[1];/* Get received comm from header */   rcomm = header[i].hdata[0];/* Get received datatype from header */   rdatat = header[i].hdata[2];/* Define source, tag and type for MPI_Get_count */   status->source = source;   status->tag = rtag;   status->type = rdatat;/* Check for receive errors */   if (nerr < 0) {      if (!ierror) {         fprintf(unit2,"OTRcv Error, nerr, source, tag = %d,%d,%d\n",                 nerr,source,tag);         if (nerr==kOTOutStateErr)            fprintf(unit2,"Endpoint not in an appropriate state\n");         else if (nerr==kENOMEMErr)            fprintf(unit2,"Open Transport has run out of memory\n");         ierror = nerr;      }   }/* Length error */   else if (rlen > slen) {      fprintf(unit2,"Read Length Error, source, tag, requested/actual = %d,%d,%d,%d\n",              source,tag,slen,rlen);      fprintf(unit2,"Possibly attempting to receive data out of order\n");      ierror = 13;   }/* Check for incomplete message, this should never be able to happen */   else if (rlen < header[i].hdata[3]) {      fprintf(unit2,"Incomplete Read, source, tag, requested/actual = %d,%d,%d,%d\n",                  source,tag,header[i].hdata[3],rlen);      ierror = 12;   }/* Comm error */   else if (rcomm != comm) {      fprintf(unit2,"Read Comm Error, source, tag, expected/received comm = %d,%d,%d,%d\n",              source,tag,comm,rcomm);      ierror = 9;   }/* Tag error */   else if ((tag >= 0) && (rtag != tag)) {      fprintf(unit2,"Read Tag Error, source, expected/received tag = %d,%d,%d\n",              source,tag,rtag);      fprintf(unit2,"Possibly attempting to receive data out of order\n");      ierror = 10;   }/* Type error */   else if (rdatat != datatype) {      fprintf(unit2,"Read Type Error, source, tag, expected/received type = %d,%d,%d,%d\n",              source,tag,datatype,rdatat);      ierror = 11;   }/* log MPI message state change and display status */   if (monitor > 0) {      if (checkesc(0)) {         ierror = -9;         writerrs("MPI_Test: ",ierror);         return ierror;      }      else if (!ierror) {/* Subtract one timestamp value from another */         OTSubtractTimeStamps(&delta,&rwrec[i].ts[0],&rwrec[i].ts[1]);/* Convert difference between time steps into microseconds */         nerr = OTTimeStampInMicroseconds(&delta);         logmess(source,-2,rlen,nerr,tag);      }   }/* Store error code */L30: status->error = ierror;/* Nullify transmission mode */   curreq[i][0] = 0;/* Nullify request handle */   *request = MPI_REQUEST_NULL;;/* Handle read and write errors */   if (ierror) {/* Write out readwrite record */      rwstat(i,unit2);      wqueue(unit2);      for (i = 0; i < MAXM; i++) {         if (curreq[i][0] != 0)            rwstat(i,unit2);      }      writerrs("MPI_Test: ",ierror);   }   return ierror;}void sndmsgf(MPI_Request request, int dest) {/* send a message fragment   request = request handle   dest = rank of destinationlocal data                          */   int i, np, nps;   long response;/* internal mpi common block   ioc = array of context pointers for notifier function            *//* internal common block for non-blocking messages   curreq = request record for transmission parameters   rwrec = read/write record for asynchronous messages   mqueue = message request queue                                     */   i = request;   np = dest;/* Obtain the current time stamp */   OTGetTimeStamp(&rwrec[i].ts[1]);/* Send data to a remote peer */L10: response = OTSnd(rwrec[i].ref,rwrec[i].buf,rwrec[i].nbytes,                      rwrec[i].flags);/* Process data which has been sent */   if (response >= 0) {/* Clear non-fatal error code */      rwrec[i].nfatal = 0;/* Set actual length sent */      rwrec[i].len += response;/* Check for incomplete header */      if (rwrec[i].len < 0) {         header[i].first.fData =                      (void *)(((unsigned char *)header[i].first.fData) + response);         header[i].first.fLen -= response;      }/* Check for incomplete data */      else if (rwrec[i].sln > rwrec[i].len) {/* Header is sent, readjust parameters to send data */         if (rwrec[i].ioflag==1) {            rwrec[i].buf = rwrec[i].sbuf;            rwrec[i].nbytes = rwrec[i].sln;            response -= header[i].first.fLen;         }/* Readjust buffer pointer */         rwrec[i].buf = (void *)(((unsigned char *)rwrec[i].buf) + response);         rwrec[i].nbytes -= response;         rwrec[i].ioflag += 1;      } /* Data is sent */      else {/* Obtain the current time stamp */         OTGetTimeStamp(&rwrec[i].ts[1]);         rwrec[i].ioflag = 0;/* Get next message if messages are queued */         if (rwrec[i].nextm > 0) {            i = rwrec[i].nextm;            if (i==mqueue[np][1])               mqueue[np][1] = 0;            ioc[np][3] = i;            i -= 1;            goto L10;         }/* Clear pointer to current send record */         else            ioc[np][3] = 0;      }   }/* Check for errors */   else {/* Process non-fatal errors */      if ((response==kOTFlowErr) || (response==kENOMEMErr))         rwrec[i].nfatal = response;/* Process fatal errors */      else {/* Find actual destination */         nps = np;         if (nps==MAXS)            nps = idproc;         fprintf(unit2,"OTSnd Error, ierr, dest, tag = %d,%d,%d\n",                 response,nps,header[i].hdata[1]);         if (response==kOTOutStateErr)            fprintf(unit2,"Endpoint not in an appropriate state\n");/* Determine cause of a kOTLookErr */         else if (response==kOTLookErr)            fprintf(unit2,"OTLookErr, cause=%d\n",OTLook(rwrec[i].ref));/* Set iocompletion flag to error */         rwrec[i].ioflag = response;/* Clear pointer to current send record */         ioc[np][3] = 0;      }   }   return;}void rcvmsgf(MPI_Request request, int source) {/* receive a message fragment   request = request handle   source = rank of sourcelocal data                          */   int i, np, j;   long response;/* internal mpi common block   ioc = array of context pointers for notifier function            *//* internal common block for non-blocking messages   curreq = request record for transmission parameters   rwrec = read/write record for asynchronous messages   trash = trash bin for unwanted data   mqueue = message request queue                                     */   i = request;   np = source;/* Obtain the current time stamp */   OTGetTimeStamp(&rwrec[i].ts[1]);/* Read data sent from a remote peer */L10: response = OTRcv(rwrec[i].ref,rwrec[i].buf,rwrec[i].nbytes,                      &rwrec[i].flags);/* Unexpected flag returned */      if (rwrec[i].flags > 1) {         rwrec[i].ioflag = -3;/* Clear pointer to current receive record */         ioc[np][2] = 0;   }/* Process data which has arrived */   else if (response >= 0) {/* Clear more flag */      rwrec[i].flags = 0;/* Clear non-fatal error code */      rwrec[i].nfatal = 0;/* Set actual length received */      rwrec[i].len += response;/* Check if all the data has arrived */      if (rwrec[i].len < header[i].hdata[3]) {/* Incomplete data */         if (rwrec[i].nbytes > response) {/* Readjust buffer pointer */            rwrec[i].buf = (void *)(((unsigned char *)rwrec[i].buf) + response);            rwrec[i].nbytes -= response;            if (rwrec[i].len >= 0)               rwrec[i].ioflag += 1;         }/* Header is received, readjust parameters to receive data */         else if (rwrec[i].ioflag==1) {            rwrec[i].buf = rwrec[i].sbuf;            rwrec[i].nbytes = imin(header[i].hdata[3],rwrec[i].sln);            rwrec[i].ioflag = 2;            goto L10;         }/* Data is received and buffer is full */         else {            rwrec[i].buf = &trash;            rwrec[i].nbytes = 1024;            goto L10;         }      }/* Data is received */      else {/* Obtain the current time stamp */         OTGetTimeStamp(&rwrec[i].ts[1]);         rwrec[i].ioflag = 0;/* Get next message if messages are queued */         if (rwrec[i].nextm > 0) {            i = rwrec[i].nextm;            if (i==mqueue[np][0])               mqueue[np][0] = 0;            ioc[np][2] = i;         }/* Clear pointer to current read record */         else            ioc[np][2] = 0;      }   }/* Check for errors */   else {/* Process non-fatal errors */      if ((response==kOTFlowErr) || (response==kOTNoDataErr) ||         (response==kENOMEMErr))         rwrec[i].nfatal = response;/* Process potentially fatal errors */      else {/* Determine cause of a kOTLookErr */         if (response==kOTLookErr) {            j = OTLook(rwrec[i].ref);            if (j==T_GODATA) {/* Set pointer to current send record */               j = ioc[np][3] - 1;/* Send next block of data */               if ((j >= 0) && (j < MAXM)) {                  fprintf(unit2,"rcvmsgf: OTLookErr for node=%d\n",np);                  sndmsgf(j,np);                  response = ioresult((int *)&rwrec[j]);/* Report send error */                  if (response < 0) {                     fprintf(unit2,"rcvmsgf: send error=%d\n",response);                     ioc[np][3] = 0;                  }               }/* Clear more flag */               rwrec[i].flags = 0;               goto L10;            }         }/* Process fatal errors */         fprintf(unit2,"OTRcv Error, ierr, source, tag = %d,%d,%d\n",                 response,np,header[i].hdata[1]);         if (response==kOTOutStateErr)            fprintf(unit2,"Endpoint not in an appropriate state\n");         else if (response==kOTLookErr)            fprintf(unit2,"OTLookErr, unknown cause=%d",j);/* Set iocompletion flag to error */         rwrec[i].ioflag = response;/* Clear pointer to current receive record */         ioc[np][2] = 0;      }   }   return;}int MPI_Wait(MPI_Request *request, MPI_Status *status) {/* wait for an MPI send or receive to complete   request = request handle   status = status object   input: request   output: request, statuslocal data                                     */   int ierror, flag;L10: ierror = MPI_Test(request,&flag,status);   if (!flag) goto L10;   return ierror;}int MPI_Request_free(MPI_Request *request) {/* free a communication request object   request = request handle   input: request   output: requestlocal data                                                            */   int ierror, i;/* internal mpi common block   nproc = number of real or virtual processors obtained              *//* internal common block for non-blocking messages   curreq = request record for transmission parameters   rwrec = read/write record for asynchronous messages                */   ierror = 0;/* check for error conditions */   i = *request;/* MPI not initialized */   if (nproc <= 0)      ierror = 1;/* null request */   else if (*request < 0) {      return 0;   }/* invalid request handle */   else if (i >= MAXM)      ierror = 16;   else if (curreq[i][0]==0)      ierror = 16;/* handle errors */   if (ierror) {      writerrs("MPI_Request_free ",ierror);      return ierror;   }/* Check if data read or write has completed */   if (ioresult((int *)&rwrec[i]) <= 0) {/* Nullify transmission mode */      curreq[i][0] = 0;/* Nullify request handle */      *request = MPI_REQUEST_NULL;   }   else {      fprintf(unit2,"MPI_Request_free: Message not Completed\n");/* Write out readwrite record */      rwstat(i,unit2);      ierror = 32;   }   return ierror;}int MPI_Sendrecv(void* sendbuf, int sendcount, MPI_Datatype sendtype,                 int dest, int sendtag, void* recvbuf, int recvcount,                 MPI_Datatype recvtype, int source, int recvtag,                 MPI_Comm comm, MPI_Status *status) {/* blocking send and receive operation   sendbuf = initial address of send buffer   sendcount = number of entries to send   sendtype = type of entries in send buffer   dest = rank of destination   sendtag = send tag   recvbuf = initial address of receive buffer   recvcount = max number of entries to receive   recvtype = type of entries in receive buffer   source = rank of source   recvtag = receive tag   comm = communicator   status = return status   input: sendbuf, sendcount, sendtype, dest, sendtag, recvbuf, recvcount         recvtype, source, recvtag, comm   output: recvbuf, statuslocal data                                                                */   int ierror;   MPI_Request recvreq, sendreq;/* post non-blocking receive and send */   ierror = MPI_Irecv(recvbuf,recvcount,recvtype,source,recvtag,comm,&recvreq);   ierror = MPI_Isend(sendbuf,sendcount,sendtype,dest,sendtag,comm,&sendreq);/* wait for send and receive */   ierror = MPI_Wait(&sendreq,status);   ierror = MPI_Wait(&recvreq,status);   return ierror;}int MPI_Ssend(void* buf, int count, MPI_Datatype datatype, int dest,              int tag, MPI_Comm comm) {/* blocking synchronous mode send   buf = initial address of send buffer   count = number of entries to send   datatype = datatype of each entry   dest = rank of destination   tag = message tag   comm = communicator   input: buf, count, datatype, dest, tag, comm   comment: this is just a temporary stublocal data                                                           */   int ierror;   ierror = MPI_Send(buf,count,datatype,dest,tag,comm);   return ierror;}int MPI_Issend(void* buf, int count, MPI_Datatype datatype, int dest,               int tag, MPI_Comm comm, MPI_Request *request) {/* start a non-blocking synchronous mode send   buf = initial address of send buffer   count = number of entries to send   datatype = datatype of each entry   dest = rank of destination   tag = message tag   comm = communicator   request = request handle   input: buf, count, datatype, dest, tag, comm   output: request   comment: this is just a temporary stublocal data                                                        */   int ierror;   ierror = MPI_Isend(buf,count,datatype,dest,tag,comm,request);   return ierror;}int MPI_Waitall(int count, MPI_Request *array_of_requests,                MPI_Status *array_of_statuses) {/* wait for a collection of specified MPI sends or receives to complete   count = list length   array_of_requests = array of request handles   array_of_statuses = array of status objects   input: count, array_of_requests   output: array_of_requests, array_of_statuseslocal data                                                             */   int ierror, i, ierr;/* invalid count */   if (count < 0) {      fprintf(unit2,"Invalid list length = %d\n",count);      ierror = 17;      writerrs("MPI_Waitall: ",ierror);      return ierror;   }   ierror = 0;   for (i = 0; i < count; i++) {      ierr = MPI_Wait(&array_of_requests[i],&array_of_statuses[i]);      if (ierr)      ierror = MPI_ERR_IN_STATUS;   }   return ierror;}int MPI_Waitany(int count, MPI_Request *array_of_requests,                int *index, MPI_Status *status) {/* wait for any specified MPI send or receive to complete   count = list length   array_of_requests = array of request handles   index = index of request handle that completed   status = status object   input: count, array_of_requests   output: array_of_requests, index, statuslocal data                                                 */   int ierror, i, k, flag;/* invalid count */   if (count < 0) {      fprintf(unit2,"Invalid list length = %d\n",count);      ierror = 17;      writerrs("MPI_Waitany: ",ierror);      return ierror;   }/* find number of requests already completed */   k = 0;   for (i = 0; i < count; i++)      if (array_of_requests[i] < 0)         k = k + 1;   if (k==count) {      *index = -1;      ierror = 0;      return ierror;   }   i = 0;L20: flag = 0;   if (array_of_requests[i] >= 0)      ierror = MPI_Test(&array_of_requests[i],&flag,status);   if (flag)      *index = i;   else {      i += 1;      if (i >= count)         i = 0;      goto L20;   }   return ierror;}int MPI_Get_count(MPI_Status *status, MPI_Datatype datatype,                  int *count) {/* get the number of "top level" elements   status = return status of receive operation   datatype = datatype of each receive buffer entry   count = number of received entries   input: status, datatype   output: countlocal data                                           */   int ierror;/* internal mpi common block   nproc = number of real or virtual processors obtained    */        ierror = 0;   *count = 0;/* MPI not initialized */   if (nproc <= 0)      ierror = 1;/* mismatched datatype */   else if (datatype != status->type)      ierror = 18;/* calculate count */   else if ((datatype==MPI_INT) || (datatype==MPI_FLOAT)) {      *count = status->len/4;      if (4*(*count) != status->len)         *count = MPI_UNDEFINED;   }   else if (datatype==MPI_DOUBLE) {      *count = status->len/8;      if (8*(*count) != status->len)         *count = MPI_UNDEFINED;   }   else if (datatype==MPI_BYTE)      *count = status->len;   else if ((datatype==MPI_2INT) || (datatype==MPI_FLOAT_INT)) {         *count = status->len/8;      if (8*(*count) != status->len)         *count = MPI_UNDEFINED;   }   else if (datatype==MPI_DOUBLE_INT) {      *count = status->len/16;      if (16*(*count) != status->len)         *count = MPI_UNDEFINED;   }/* invalid datatype */   else      ierror = 7;/* handle errors */   if (ierror)      writerrs("MPI_Get_count: ",ierror);   return ierror;}int MPI_Initialized(int *flag) {/* indicate whether MPI_Init has been called   flag = true if MPI_Init has been called, false otherwise   output: flaglocal data                                                  */   int ierror;/* internal mpi common block   nproc = number of real or virtual processors obtained    */   if (nproc > 0)      *flag = 1;   else      *flag = 0;   ierror = 0;   return ierror;}int MPI_Comm_size(MPI_Comm comm, int *size) {/* determine the size of the group associated with a communicator   comm = communicator (this is ignored)   size = number of processors in the group of comm   input: comm   output: sizelocal data                                                         */   int ierror, np;/* internal mpi common block   nproc = number of real or virtual processors obtained   mapcomm = communicator map                                      */   ierror = 0;/* check for error conditions *//* MPI not initialized */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm < 0) || (comm >= MAXC))      ierror = 2;/* get size */   else {      np = mapcomm[comm][MAXS];      if ((np > 0) && (np <= nproc))         *size = np;      else         ierror = 2;   }/* handle errors */   if (ierror)      writerrs("MPI_Comm_size: ",ierror);   return ierror;}int MPI_Comm_rank(MPI_Comm comm, int *rank) {/* determine the rank of the calling process in the communicator   comm = communicator (this is ignored)   rank = rank of the calling process in group of comm   input: comm   output: ranklocal data                                                        */   int ierror, np;/* internal mpi common block   nproc = number of real or virtual processors obtained   idproc = processor id   mapcomm = communicator map                                     */   ierror = 0;/* check for error conditions *//* MPI not initialized        */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm < 0) || (comm >= MAXC))      ierror = 2;/* get rank */   else {      np = mapcomm[comm][MAXS];      if ((np > 0) && (np <= nproc)) {         *rank = mapcomm[comm][MAXS+1];         if ((*rank >= 0) && (*rank < np)) {            if (mapcomm[comm][*rank] != idproc)               ierror = 29;         }         else            ierror = 29;      }      else         ierror = 2;   }/* handle errors */   if (ierror)      writerrs("MPI_Comm_rank: ",ierror);   return ierror;}int MPI_Comm_dup(MPI_Comm comm, MPI_Comm *newcomm) {/* duplicate existing communicator with all its cached information   comm = communicator   newcomm = new communicator   input: comm   output: newcommlocal data                                                               */   int ierror, np, i, j, k;/* declare internal mpi common block   nproc = number of real or virtual processors obtained   mapcomm = communicator map                                            *//* declare common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */   ierror = 0;   *newcomm = MPI_COMM_NULL;/* check for error conditions *//* MPI not initialized */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm < 0) || (comm >= MAXC))      ierror = 2;/* communicator errors */   else {      np = mapcomm[comm][MAXS];/* communicator not mapped */      if ((np <= 0) || (np > nproc))         ierror = 2;   }/* handle errors */   if (ierror) {      writerrs("MPI_Comm_dup: ",ierror);      return ierror;   }   if (monitor==2)      fprintf(unit2,"MPI_Comm_dup started\n");/* find space for communication record */   i = 1;L10: i += 1;   if (i >= MAXC) {      fprintf(unit2,"too many communicators\n");      ierror = 25;      writerrs("MPI_Comm_dup: ",ierror);      return ierror;   }   else if (mapcomm[i][MAXS] > 0)      goto L10;/* check if all nodes agree on new communicator */   ierror =  MPI_Allreduce(&i,&j,1,MPI_INT,MPI_MIN,comm);   ierror =  MPI_Allreduce(&i,&k,1,MPI_INT,MPI_MAX,comm);   if (j != k) {/* try to find another communicator */      i = k - 1;      goto L10;  }/* duplicate mapping */   for (j = 0; j < MAXS+MAXD+3; j++)      mapcomm[i][j]= mapcomm[comm][j];/* assign communicator */   *newcomm = i;   if (monitor==2)      fprintf(unit2,"MPI_Comm_dup complete\n");   return ierror;}int MPI_Comm_split(MPI_Comm comm, int color, int key, MPI_Comm *newcomm) {/* create a new communicator based on color and key   comm = communicator   color = control of subset assignment   key = control of rank assignment   newcomm = new communicator   input: comm, color, key   output: newcommlocal data                                                               */   int ierror, np, i, mp, j, k, l, kmin;/* declare internal mpi common block   nproc = number of real or virtual processors obtained   idproc = processor id   mapcomm = communicator map                                            *//* declare common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */   ierror = 0;   *newcomm = MPI_COMM_NULL;/* check for error conditions *//* MPI not initialized */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm < 0) || (comm >= MAXC))      ierror = 2;/* invalid color */   else if (color < (-1)) {      fprintf(unit2,"Invalid color = %d\n",color);      ierror = 23;   }/* communicator errors */   else {      np = mapcomm[comm][MAXS];/* communicator not mapped */      if ((np <= 0) || (np > nproc))         ierror = 2;   }/* handle errors */   if (ierror) {      writerrs("MPI_Comm_split: ",ierror);      return ierror;   }   if (monitor==2)      fprintf(unit2,"MPI_Comm_split started\n");/* find space for communication record */   i = 1;L10: i += 1;   if (i >= MAXC) {      fprintf(unit2,"too many communicators, color = %d\n",color);      ierror = 25;      writerrs("MPI_Comm_split: ",ierror);      return ierror;   }   else if (mapcomm[i][MAXS] > 0)      goto L10;/* check if all nodes agree on new communicator */   ierror =  MPI_Allreduce(&i,&j,1,MPI_INT,MPI_MIN,comm);   ierror =  MPI_Allreduce(&i,&k,1,MPI_INT,MPI_MAX,comm);   if (j != k) {/* try to find another communicator */      i = k - 1;      goto L10;  }/* gather all the colors */   ierror = MPI_Allgather(&color,1,MPI_INT,&mapcomm[i][0],1,MPI_INT,comm);/* this node does not participate */   if (color==MPI_UNDEFINED) {      if (monitor==2)         fprintf(unit2,"MPI_Comm_split complete\n");      return ierror;   }/* find other processors with same color */   mp = -1;   mapcomm[i][MAXS+1] = -1;   for (j = 0; j < np; j++) {      if (mapcomm[i][j]==color) {         mp += 1;         k = mapcomm[comm][j];         if ((k >= 0) || (k < np)) {            mapcomm[i][mp] = k;            if (k==idproc)               mapcomm[i][MAXS+1] = mp;         }         else            ierror = 2;      }   }   mp += 1;/* no nodes with found with color */   if (!mp) {      fprintf(unit2,"Self color not found\n");      ierror = 2;   }/* no nodes found with idproc */   else if (mapcomm[i][MAXS+1] < 0) {      fprintf(unit2,"Self rank not found\n");      ierror = 2;   }/* handle errors */   if (ierror) {      writerrs("MPI_Comm_split: ",ierror);      return ierror;   }/* finish mapping */   for (j = mp; j < MAXS; j++)      mapcomm[i][j] = MPI_UNDEFINED;   mapcomm[i][MAXS] = mp;/* assign communicator */   *newcomm = i;/* gather all the keys into MPI_COMM_SELF mapping */   ierror = MPI_Allgather(&key,1,MPI_INT,&mapcomm[1][0],1,MPI_INT,*newcomm);   k = 0;/* find lowest remaining key */L40: kmin = mapcomm[1][k];   for (j = k+1; j < mp; j++) {      if (mapcomm[1][j]  < kmin)         kmin = mapcomm[1][j];   }/* order all nodes with lowest remaining key */   for (j = k; j < mp; j++) {      if (mapcomm[1][j]==kmin) {         k += 1;/* right shift node and key order, if necessary */         if (j >= k) {            np = mapcomm[i][j];            for (l = 0; l < j-k+1; l++) {               mapcomm[i][j-l] = mapcomm[i][j-l-1];               mapcomm[1][j-l] = mapcomm[1][j-l-1];            }            mapcomm[i][k-1] = np;         }      }   }   if (k < mp)      goto L40;/* find self rank */   mapcomm[i][MAXS+1] = -1;   for (j = 0; j < mp; j++) {      k = mapcomm[i][j];      if (k==idproc)         mapcomm[i][MAXS+1] = j;    }   mapcomm[i][MAXS+2] = 0;/* restore MPI_COMM_SELF map */   mapcomm[1][0] = idproc;   for (j = 1; j < mp; j++)      mapcomm[1][j] = MPI_UNDEFINED;   if (monitor==2)      fprintf(unit2,"MPI_Comm_split complete\n");   return ierror;}int MPI_Comm_free(MPI_Comm *comm) {/* mark the communicator object for deallocation   comm = communicator   input: comm   output: commlocal data                                                 */   int ierror, np, i;/* declare internal mpi common block   nproc = number of real or virtual processors obtained   mapcomm = communicator map                              */   ierror = 0;/* check for error conditions *//* MPI not initialized */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((*comm < 0) || (*comm >= MAXC))      ierror = 2;/* release communicator */   else if (*comm > 1) {      np = mapcomm[*comm][MAXS];      if ((np > 0) && (np <= nproc)) {/* clear mapping */         for (i = 0; i < MAXS; i++) {            mapcomm[*comm][i] = 0;            mapcomm[*comm][MAXS] = 0;            mapcomm[*comm][MAXS+1] = MPI_UNDEFINED;            mapcomm[*comm][MAXS+2] = 0;            *comm = MPI_COMM_NULL;         }      }      else         ierror = 2;   }/* handle errors */   if (ierror)      writerrs("MPI_Comm_free: ",ierror);   return ierror;}int MPI_Cart_create(MPI_Comm comm_old, int ndims, int *dims, int *periods,                    int reorder, MPI_Comm *comm_cart) {/* make new communicator to which topology information has been attached   comm_old = input communicator   ndims = number of dimensions of Cartesian grid   dims = array specifying the number of processes in each dimension   periods = array specifying whether grid is periodic or not   reorder = specifies whether ranks may be reordered or not (ignored)   comm_cart = communicator with new Carteisan topology   input: comm_old, ndims, dims, periods, reorder   output: comm_cartlocal data                                                               */   int ierror, np, mp, i, j, k;/* declare internal mpi common block   nproc = number of real or virtual processors obtained   mapcomm = communicator map                                            *//* declare common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */   ierror = 0;   *comm_cart = MPI_COMM_NULL;/* check for error conditions *//* MPI not initialized */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm_old < 0) || (comm_old >= MAXC))      ierror = 2;  /* invalid topology */   else if ((ndims < 0) || (ndims > MAXD)) {       fprintf(unit2,"Invalid topology dimension = %d\n",ndims);       ierror = 26;   }/* communicator errors */   else {      np = mapcomm[comm_old][MAXS];/* communicator not mapped */      if ((np <= 0) || (np > nproc))         ierror = 2;/* check topology length */      else {         mp = 1;         for (i = 0; i < ndims; i++)            mp = mp*dims[i];         if (!ndims)            mp = 0;         if ((mp < 0) || (mp > np)) {            fprintf(unit2,"Invalid Cartesian topology size = %d\n",mp);            ierror = 27;         }      }   }/* handle errors */   if (ierror) {      writerrs("MPI_Cart_create: ",ierror);      return ierror;   }   if (!mp)      return ierror;   if (monitor==2)      fprintf(unit2,"MPI_Cart_create started\n");/* find space for communication record */   i = 1;L20: i += 1;   if (i >= MAXC) {      fprintf(unit2,"too many communicators\n");      ierror = 25;      writerrs("MPI_Cart_create: ",ierror);      return ierror;   }   else if (mapcomm[i][MAXS] > 0)      goto L20;/* check if all nodes agree on new communicator */   ierror =  MPI_Allreduce(&i,&j,1,MPI_INT,MPI_MIN,comm_old);   ierror =  MPI_Allreduce(&i,&k,1,MPI_INT,MPI_MAX,comm_old);   if (j != k) {/* try to find another communicator */      i = k - 1;      goto L20;  }/* quit if processor is beyond range of topology */   if (mapcomm[comm_old][MAXS+1] >= mp) {      if (monitor==2)         fprintf(unit2,"MPI_Cart_create complete\n");      return ierror;   }/* create mapping */   for (j = 0; j < mp; j++)      mapcomm[i][j] = mapcomm[comm_old][j];   for (j = mp; j < MAXS; j++)      mapcomm[i][j]= MPI_UNDEFINED;   mapcomm[i][MAXS] = mp;   mapcomm[i][MAXS+1] = mapcomm[comm_old][MAXS+1];/* store topology */   mapcomm[i][MAXS+2] = ndims;   for (j = 0; j < ndims; j++)   if (periods[j])      mapcomm[i][MAXS+3+j] = dims[j];   else      mapcomm[i][MAXS+3+j] = -dims[j];/* assign communicator */   *comm_cart = i;   if (monitor==2)      fprintf(unit2,"MPI_Cart_create complete\n");   return ierror;}int MPI_Cart_coords(MPI_Comm comm, int rank, int maxdims, int *coords) {/* determine process coords in Cartesian topology, given rank in group   comm = communicator with Cartesian structure   rank = rank of a process within group of comm   maxdims = length of vector coords in the calling program   coords = array containing Cartesian coordinates of specified process   input: comm, rank, maxdims   output: coordslocal data                                                              */   int ierror, np, ndims, i, j;/* declare internal mpi common block   nproc = number of real or virtual processors obtained   mapcomm = communicator map                                            */   ierror = 0;/* check for error conditions *//* MPI not initialized */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm < 0) || (comm >= MAXC))      ierror = 2;/* communicator errors */   else {      np = mapcomm[comm][MAXS];      ndims = mapcomm[comm][MAXS+2];/* communicator not mapped */      if ((np <= 0) || (np > nproc))         ierror = 2;/* invalid topology */      else if ((ndims < 1) || (ndims > MAXD)) {         fprintf(unit2,"Invalid topology dimension = %d\n",ndims);         ierror = 26;      }/* invalid vector length */      else if (maxdims < ndims) {          fprintf(unit2,"Vector length too small = %d\n",maxdims);          ierror = 28;      }/* invalid rank */      else {         if ((rank < 0) || (rank >= np)) {            fprintf(unit2,"Invalid rank = %d\n",rank);            ierror = 29;         }      }   }/* handle errors */   if (ierror) {      writerrs("MPI_Cart_coords: ",ierror);      return ierror;   }/* calculate cartesian coordinates */   j = rank;   for (i = 0; i < ndims; i++) {      np = np/abs(mapcomm[comm][MAXS+3+i]);      coords[i] = j/np;      j -= coords[i]*np;   }   return ierror;}int MPI_Cart_get(MPI_Comm comm, int maxdims, int *dims, int *periods,                int *coords) {/* retrieve cartesian topology information associated with communicator   comm = communicator with Cartesian structure   maxdims = length of vectors dims, periods and coords   dims = number of processes for each Cartesian dimension   periods = periodicity (true/false) for each Cartesian dimension   coords = array containing Cartesian coordinates of specified process   input: comm, maxdims   output: dims, periods, coordslocal data                                                               */   int ierror, np, ndims, rank, i, j, k;/* declare internal mpi common block   nproc = number of real or virtual processors obtained   idproc = processor id   mapcomm = communicator map                                            */   ierror = 0;/* check for error conditions *//* MPI not initialized */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm < 0) || (comm >= MAXC))      ierror = 2;/* communicator errors */   else {      np = mapcomm[comm][MAXS];      ndims = mapcomm[comm][MAXS+2];      rank = mapcomm[comm][MAXS+1];/* communicator not mapped */      if ((np <= 0) || (np > nproc))         ierror = 2;/* invalid topology */      else if ((ndims < 1) || (ndims > MAXD)) {         fprintf(unit2,"Invalid topology dimension = %d\n",ndims);         ierror = 26;      }/* invalid vector length */      else if (maxdims < ndims) {          fprintf(unit2,"Vector length too small = %d\n",maxdims);          ierror = 28;      }/* get rank */      else if ((rank >= 0) && (rank < np)) {         if (mapcomm[comm][rank] != idproc)            ierror = 29;      }      else         ierror = 29;   }/* handle errors */   if (ierror) {      writerrs("MPI_Cart_get: ",ierror);      return ierror;   }/* calculate dimension, periodicity, and cartesian coordinates */   j = rank;   for (i = 0; i < ndims; i++) {      k = mapcomm[comm][MAXS+3+i];      if (k > 0)         periods[i] = 1;      else {         periods[i] = 0;         k = -k;      }      dims[i] = k;      np = np/k;      coords[i] = j/np;      j -= coords[i]*np;   }   return ierror;}int MPI_Cart_shift(MPI_Comm comm, int direction, int disp, int *rank_source,                   int *rank_dest) {/* return shifted source and destination ranks given shift direction and   amount   comm = communicator with Cartesian structure   direction = coordinate dimension shift   disp = displacement (> 0: upwards shift, < 0: downwards shift)   rank_source = rank of source process   rank_dest = rank of destination process   input: comm, direction, disp   output: rank_source, rank_destlocal data                                                               */   int ierror, np, ndims, rank, i, j, k, l, shift;/* declare internal mpi common block   nproc = number of real or virtual processors obtained   mapcomm = communicator map                                            */   ierror = 0;/* check for error conditions *//* MPI not initialized */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm < 0) || (comm >= MAXC))      ierror = 2;/* communicator errors */   else {      np = mapcomm[comm][MAXS];      ndims = mapcomm[comm][MAXS+2];      rank = mapcomm[comm][MAXS+1];/* communicator not mapped */      if ((np <= 0) || (np > nproc))         ierror = 2;/* invalid topology */      else if ((ndims < 1) || (ndims > MAXD)) {         fprintf(unit2,"Invalid topology dimension = %d\n",ndims);         ierror = 26;      }/* invalid direction */      else if ((direction < 0) || (direction >= ndims)) {          fprintf(unit2,"Invalid direction = %d\n",direction);          ierror = 31;      }/* get rank */      else if ((rank >= 0) && (rank < np)) {         if (mapcomm[comm][rank] != idproc)            ierror = 29;      }      else         ierror = 29;   }/* handle errors */   if (ierror) {      writerrs("MPI_Cart_shift: ",ierror);      return ierror;   }/* check if shift amount is zero */   if (!disp) {      *rank_source = rank;      *rank_dest = rank;      return ierror;   }/* find coordinate for selected direction */   j = rank;   shift = np;   for (i = 0; i < direction+1; i++) {      shift = shift/abs(mapcomm[comm][MAXS+3+i]);      k = j/shift;      j -= k*shift;   }/* calculate size of shift */   shift = 1;   for (i = direction+1; i < ndims; i++)      shift = shift*abs(mapcomm[comm][MAXS+3+i]);/* size of selected direction */   l = mapcomm[comm][MAXS+3+direction];/* calculate new coordinate *//* periodic boundary conditions */   if (l > 0) {/* make disp also periodic */      i = abs(disp)%l;      if (disp < 0)         i = -i;/* right neighbor */      j = k + i;      if (j < 0)         j += l;      else if (j >= l)         j -= l;      *rank_dest = rank + (j - k)*shift;/* left neighbor */      j = k - i;      if (j < 0)         j += l;      else if (j >= l)         j -= l;      *rank_source = rank + (j - k)*shift;   }/* non-periodic boundary conditions */   else if (l < 0) {/* right neighbor */      j = k + disp;      if ((j < 0) || (j >= (-l)))         *rank_dest = MPI_PROC_NULL;      else         *rank_dest = rank + (j - k)*shift;/* left neighbor */      j = k - disp;      if ((j < 0) || (j >= (-l)))         *rank_source = MPI_PROC_NULL;      else         *rank_source = rank + (j - k)*shift;    }/* verify ranks */   if (*rank_source != MPI_PROC_NULL) {      if ((*rank_source < 0) || (*rank_source >= np)) {         fprintf(unit2,"rank_source = %d\n",*rank_source);         ierror = 29;      }   }   if (*rank_dest != MPI_PROC_NULL) {      if ((*rank_dest < 0) || (*rank_dest >= np)) {         fprintf(unit2,"rank_dest = %d\n",*rank_dest);         ierror = 29;      }   }/* process errors */   if (ierror)      writerrs("MPI_Cart_shift: ",ierror);   return ierror;}int MPI_Cart_rank(MPI_Comm comm, int *coords, int *rank) {/* determine process rank in communicator, given Cartesian location   comm = communicator with Cartesian structure   coords = array specifying Cartesian coordinates of a process   rank = rank of specified process   input: comm, coords   output: ranklocal data                                                           */   int ierror, np, ndims, i, j, k, l;/* declare internal mpi common block   nproc = number of real or virtual processors obtained   mapcomm = communicator map                                        */   ierror = 0;/* check for error conditions *//* MPI not initialized */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm < 0) || (comm >= MAXC))      ierror = 2;/* communicator errors */   else {      np = mapcomm[comm][MAXS];      ndims = mapcomm[comm][MAXS+2];/* communicator not mapped */      if ((np <= 0) || (np > nproc))         ierror = 2;/* invalid topology */      else if ((ndims < 1) || (ndims > MAXD)) {         fprintf(unit2,"Invalid topology dimension = %d\n",ndims);         ierror = 26;      }/* invalid coords */      else {         for (i = 0; i < ndims; i++) {            j = mapcomm[comm][MAXS+3+i];            if (j < 0) {               if ((coords[i] < 0) || (coords[i] >= (-j))) {                  fprintf(unit2,"Invalid ith coord = %d,%d\n",i,coords[i]);                  ierror = 30;               }            }         }      }   }/* handle errors */   if (ierror) {      writerrs("MPI_Cart_rank: ",ierror);      return ierror;   }/* calculate rank, wrap periodic coordinates */   l = 0;   for (i = 0; i < ndims; i++) {      j = mapcomm[comm][MAXS+3+i];      k = coords[i];      if (j > 0) {         if (k < 0)            k += j;         else if (k >= j)            k -= j;      }      else         j = -j;      l = k + j*l;   }/* verify rank */   if ((l < 0) || (l >= np)) {      fprintf(unit2,"Invalid coords, resulting rank = %d\n",l);      ierror = 30;      writerrs("MPI_Cart_rank: ",ierror);   }   else      *rank = l;   return ierror;}int MPI_Cart_sub(MPI_Comm comm, int *remain_dims, MPI_Comm *newcomm) {/* partition communicator into subgroups that form lower-dimensional   Cartesian subgrids   comm = communicator with Cartesian structure   remain_dims = each entry of remain_dims specifies whether dimension is   kept in the subgrid or not   newcomm = communicator containing the subgrid   input: comm, remain_dims   output: newcommlocal data                                                               */   int ierror, np, ndims, rank, i, j, k, l, m, mp, color, key;/* declare internal mpi common block   nproc = number of real or virtual processors obtained   idproc = processor id   mapcomm = communicator map                                            *//* declare common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */   ierror = 0;   *newcomm = MPI_COMM_NULL;/* check for error conditions *//* MPI not initialized */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm < 0) || (comm >= MAXC))      ierror = 2;  /* communicator errors */   else {      np = mapcomm[comm][MAXS];      ndims = mapcomm[comm][MAXS+2];      rank = mapcomm[comm][MAXS+1];/* communicator not mapped */      if ((np <= 0) || (np > nproc))         ierror = 2;/* invalid topology */      else if ((ndims < 1) || (ndims > MAXD)) {         fprintf(unit2,"Invalid topology dimension = %d\n",ndims);         ierror = 26;      }/* get rank */      else if ((rank >= 0) && (rank < np)) {         if (mapcomm[comm][rank] != idproc)            ierror = 29;      }      else         ierror = 29;   }/* handle errors */   if (ierror) {      writerrs("MPI_Cart_sub: ",ierror);      return ierror;   }/* find dimension of new topology */   k = 0;   for (j = 0; j < ndims; j++) {      if (remain_dims[j])         k += 1;   }/* empty topology */   if (!k)      return ierror;   if (monitor==2)      fprintf(unit2,"MPI_Cart_sub started\n");/* find space for communication record */   i = 1;L20: i += 1;   if (i >= MAXC) {      fprintf(unit2,"too many communicators\n");      ierror = 25;      writerrs("MPI_Cart_sub: ",ierror);      return ierror;   }   else if (mapcomm[i][MAXS] > 0)      goto L20;/* check if all nodes agree on new communicator */   ierror =  MPI_Allreduce(&i,&j,1,MPI_INT,MPI_MIN,comm);   ierror =  MPI_Allreduce(&i,&k,1,MPI_INT,MPI_MAX,comm);   if (j != k) {/* try to find another communicator */      i = k - 1;      goto L20;  }/* find color for missing dimension */   j = rank;   color = 0;   key = 0;   mp = np;   for (l = 0; l < ndims; l++) {      m = abs(mapcomm[comm][MAXS+3+l]);      mp = mp/m;      k = j/mp;      j -= k*mp;      if (remain_dims[l])         key = k + key*m;      else         color = k + color*m;   }/* gather all the colors */   ierror = MPI_Allgather(&color,1,MPI_INT,&mapcomm[i][0],1,MPI_INT,comm);/* find other processors with same color */   mp = -1;   mapcomm[i][MAXS+1] = -1;   for (j = 0; j < np; j++) {      if (mapcomm[i][j]==color) {         mp += 1;         k = mapcomm[comm][j];         if ((k >= 0) || (k < np)) {            mapcomm[i][mp] = k;            if (k==idproc)               mapcomm[i][MAXS+1] = mp;         }         else            ierror = 2;      }   }   mp += 1;/* no nodes with found with color */   if (!mp) {      fprintf(unit2,"Self color not found\n");      ierror = 2;   }/* no nodes found with idproc */   else if (mapcomm[i][MAXS+1] < 0) {      fprintf(unit2,"Self rank not found\n");      ierror = 2;   }/* handle errors */   if (ierror) {      writerrs("MPI_Cart_sub: ",ierror);      return ierror;   }/* finish mapping */   for (j = mp; j < MAXS; j++)      mapcomm[i][j] = MPI_UNDEFINED;   mapcomm[i][MAXS] = mp;/* assign communicator */   *newcomm = i;/* create new topology */   k = 0;   for (j = 0; j < ndims; j++) {      if (remain_dims[j]) {         k += 1;         mapcomm[i][MAXS+2+k] = mapcomm[comm][MAXS+3+j];      }   }   mapcomm[i][MAXS+2] = k;   if (monitor==2)      fprintf(unit2,"MPI_Cart_sub complete\n");   return ierror;}int MPI_Dims_create(int nnodes, int ndims, int *dims) {/* create a division of processes in a Cartesian grid   nnodes = number of nodes in a grid   ndims = number of Cartesian dimensions   dims = array specifying number of nodes in each dimension   input: nnodes, ndims, dims   output: dimslocal data                                                    */   int ierror, i, j, nd, mp, md;   ierror = 0;/* check for errors */   nd = 0;   mp = 1;   for (i = 0; i < ndims; i++) {      if (dims[i]==0)         nd += 1;      else if (dims[i] > 0)         mp = mp*dims[i];      else if (dims[i] < 0)         ierror = 26;   }   if (!nd)      return ierror;   if (ierror)      fprintf(unit2,"Invalid topology dimension\n");   else if ((nnodes < 1) || (nnodes > MAXS)) {      fprintf(unit2,"Invalid number of nodes = %d\n",nnodes);      ierror = 24;   }   else {      md = nnodes/mp;      if ((md*mp) != nnodes) {         fprintf(unit2,"Topology dimension, node number inconsistent\n");         ierror = 26;      }   }/* handle errors */   if (ierror) {      writerrs("MPI_Dims_create: ",ierror);      return ierror;   }/* look for nd factors of md */   for (i = 0; i < ndims; i++) {      if (!dims[i]) {         mp = (int) (exp(log((float) md/(float) nd)) + .0001);         if (((int) (pow(mp,nd) + .0001)) < md)            mp += 1;L20:     j = md/mp;         if ((j*mp)==md) {            dims[i] = mp;            md = j;            nd -= 1;         }         else {            mp += 1;            if (mp <= md)               goto L20;            fprintf(unit2,"MPI_Dims_create: factor not found\n");            ierror = 26;         }      }   }/* sanity check */   if ((md != 1) || (nd != 0)) {      fprintf(unit2,"MPI_Dims_create: missing factors\n");      ierror = 26;   }   return ierror;}int MPI_Bcast(void* buffer, int count, MPI_Datatype datatype,              int root, MPI_Comm comm) {/* broadcast a message from root to all processes in comm   buffer = starting address of buffer   count = number of entries in buffer   datatype = datatype of buffer   root = rank of broadcast root   comm = communicator   input: buffer, count, datatype, root, comm   output: bufferlocal data                                                               */   int ierror, i, np, id, rank;   MPI_Status status;/* internal mpi common block   nproc = number of real or virtual processors obtained   idproc = processor id   mapcomm = communicator map                                            *//* declare common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */   ierror = 0;/* check for error conditions *//* MPI not initialized        */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm < 0) || (comm >= MAXC))      ierror = 2;/* invalid root */   else if ((root < 0) || (root >= nproc))      ierror = 19;/* communicator errors */   else {      np = mapcomm[comm][MAXS];      id = mapcomm[comm][root];/* communicator not mapped */      if ((np <= 0) || (np > nproc))         ierror = 2;/* invalid root */      else if ((root < 0) || (root >= np))         ierror = 19;/* invalid mapping */      else if ((id < 0) || (id >= nproc)) {         fprintf(unit2,"Invalid mapping, root, node = %d,%d\n",root,id);         ierror = 2;      }/* get rank */      else {         rank = mapcomm[comm][MAXS+1];         if ((rank >= 0) && (rank < np)) {            if (mapcomm[comm][rank] != idproc)               ierror = 29;         }         else            ierror = 29;      }   }/* handle errors */   if (ierror) {      writerrs("MPI_Bcast: ",ierror);      return ierror;   }   if (monitor==2)      fprintf(unit2,"MPI_Bcast started\n");/* start broadcast */   if (rank==root) {      for (i = 0; i < np; i++) {         if (i != root)           ierror = MPI_Send(buffer,count,datatype,i,0,comm);      }   }   else      ierror = MPI_Recv(buffer,count,datatype,root,0,comm,&status);   if (monitor==2)      fprintf(unit2,"MPI_Bcast complete\n");   return ierror;}int MPI_Barrier(MPI_Comm comm) {/* blocks each process in comm until all processes have called it.   comm = communicator   input: commlocal data                                                               */   int ierror, np, rank, ntasks, isync, irync, i;   MPI_Status status;/* internal mpi common block   nproc = number of real or virtual processors obtained   idproc = processor id   mapcomm = communicator map                                            *//* declare common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */   ierror = 0;/* check for error conditions *//* MPI not initialized        */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm < 0) || (comm >= MAXC))      ierror = 2;/* communicator errors */   else {      np = mapcomm[comm][MAXS];/* communicator not mapped */      if ((np <= 0) || (np > nproc))         ierror = 2;/* get rank */      else {         rank = mapcomm[comm][MAXS+1];         if ((rank >= 0) && (rank < np)) {            if (mapcomm[comm][rank] != idproc)               ierror = 29;         }         else            ierror = 29;      }   }/* handle errors */   if (ierror) {      writerrs("MPI_Barrier: ",ierror);      return ierror;   }   if (monitor==2)      fprintf(unit2,"MPI_Barrier started\n");/* begin synchronization */   ntasks = np - 1;   isync = -1;   if (rank==0) {/* processor 0 receives a message from everyone else */      for (i=1; i <= ntasks; i++) {         ierror = MPI_Recv(&irync,1,MPI_INT,i,0,comm,&status);         if (irync != isync)            fprintf(unit2,"sync error from proc %d\n",i);      }/* then sends an acknowledgment back */      isync = 1;      ierror = MPI_Bcast(&isync,1,MPI_INT,0,comm);   }   else {/* remaining processors send a message to processor 0 */      ierror = MPI_Send(&isync,1,MPI_INT,0,0,comm);/* then receive an acknowledgement back */      isync = 1;      ierror = MPI_Bcast(&irync,1,MPI_INT,0,comm);      if (irync != isync)         fprintf(unit2,"rsync error at proc %d\n",rank);   }   if (monitor==2)      fprintf(unit2,"MPI_Barrier complete\n");   return ierror;}int MPI_Reduce(void* sendbuf, void* recvbuf, int count,               MPI_Datatype datatype, MPI_Op op, int root,               MPI_Comm comm) {/* applies a reduction operation to the vector sendbuf over the set of   processes specified by comm and places the result in recvbuf on root   sendbuf = address of send buffer   recvbuf = address of receive buffer   count = number of elements in send buffer   datatype = datatype of elements in send buffer   op = reduce operation (only max, min and sum currently supported)   root = rank of root process   comm = communicator   input: sendbuf, count, datatype, op, root, comm   output: recvbuflocal data                                                               */   int ierror, i, j, np, rank, id, ltmp, loct, nl, lcnt, lsize;   void *tmpbuf;   MPI_Status status;/* internal mpi common block   nproc = number of real or virtual processors obtained   idproc = processor id   mapcomm = communicator map                                            *//* declare common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */   ierror = 0;/* check for error conditions *//* MPI not initialized        */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm < 0) || (comm >= MAXC))      ierror = 2;/* invalid root */   else if ((root < 0) || (root >= nproc))      ierror = 19;/* invalid op */   else if ((op < 0) || (op > 5) || (op==3))      ierror = 20;/* communicator errors */   else {      np = mapcomm[comm][MAXS];      id = mapcomm[comm][root];/* communicator not mapped */      if ((np <= 0) || (np > nproc))         ierror = 2;/* invalid root */      else if ((root < 0) || (root >= np))         ierror = 19;/* invalid mapping */      else if ((id < 0) || (id >= nproc)) {         fprintf(unit2,"Invalid mapping, root, node = %d,%d\n",root,id);         ierror = 2;      }/* get rank */      else {         rank = mapcomm[comm][MAXS+1];         if ((rank >= 0) && (rank < np)) {            if (mapcomm[comm][rank] != idproc)               ierror = 29;         }         else            ierror = 29;      }   }/* handle errors */   if (ierror) {      writerrs("MPI_Reduce: ",ierror);      return ierror;   }/* determine size of temporary buffer */   if ((datatype==MPI_INT) || (datatype==MPI_FLOAT))      lsize = 4;   else if (datatype==MPI_DOUBLE)      lsize = 8;   else if ((datatype==MPI_2INT) && ((op==MPI_MAXLOC) || (op==MPI_MINLOC)))      lsize = 8;   else if ((datatype==MPI_FLOAT_INT) && ((op==MPI_MAXLOC) || (op==MPI_MINLOC)))      lsize = 8;   else if ((datatype==MPI_DOUBLE_INT) && ((op==MPI_MAXLOC) || (op==MPI_MINLOC)))      lsize = 16;/* invalid datatype */   else {      ierror = 7;      writerrs("MPI_Reduce: ",ierror);      return ierror;   }   loct = 0;   if (rank==root) {/* initialize by copying from send to receive buffer */      if (datatype==MPI_INT)         iredux((int *)recvbuf,(int *)sendbuf,loct,count,-1);      else if (datatype==MPI_FLOAT)         fredux((float *)recvbuf,(float *)sendbuf,loct,count,-1);      else if (datatype==MPI_DOUBLE)         dredux((double *)recvbuf,(double *)sendbuf,loct,count,-1);      else if (datatype==MPI_2INT)         iredux((int *)recvbuf,(int *)sendbuf,loct,2*count,-1);      else if (datatype==MPI_FLOAT_INT)         fredux((float *)recvbuf,(float *)sendbuf,loct,2*count,-1);   }   ltmp = lsize*count;/* allocate a nonrelocatable block of memory */   tmpbuf = NewPtr(ltmp);/* memory not available */   if (!tmpbuf) {      ierror = 21;      writerrs("MPI_Reduce: ",ierror);      return ierror;   }   if (monitor==2)      fprintf(unit2,"MPI_Reduce started\n");   ltmp = ltmp/lsize;/* send messages in groups of ltmp */   nl = (count - 1)/ltmp + 1;   lcnt = ltmp;   lsize = lsize*ltmp/4;   for (j = 0; j < nl; j++) {/* better check to see if this is OK */      if (j==(nl-1))         lcnt = count - ltmp*(nl - 1);      if (rank==root) {/* root receives data from everyone else */         for (i = 0; i < np; i++) {            if (i != root) {               ierror = MPI_Recv(tmpbuf,lcnt,datatype,i,j+1,comm,&status);/* reduce data */               if (datatype==MPI_INT)                  iredux((int *)recvbuf,(int *)tmpbuf,loct,lcnt,op);               else if (datatype==MPI_FLOAT)                  fredux((float *)recvbuf,(float *)tmpbuf,loct,lcnt,op);               else if (datatype==MPI_DOUBLE)                  dredux((double *)recvbuf,(double *)tmpbuf,loct,lcnt,op);               else if (datatype==MPI_2INT)                  iredux((int *)recvbuf,(int *)tmpbuf,loct,lcnt,op);               else if (datatype==MPI_FLOAT_INT)                  fredux((float *)recvbuf,(float *)tmpbuf,loct,lcnt,op);            }         }         loct = loct + ltmp;      }      else {/* remaining processors send data to root */         ierror = MPI_Send(&((int *)sendbuf)[loct],lcnt,datatype,root,j+1,comm);         loct = loct + lsize;      }   }/* release nonrelocatable memory block */   DisposePtr((char *)tmpbuf);   if (monitor==2)      fprintf(unit2,"MPI_Reduce complete\n");   return ierror;}int MPI_Scan(void* sendbuf, void* recvbuf, int count,             MPI_Datatype datatype, MPI_Op op, MPI_Comm comm) {/* performs a parallel prefix reduction on data distributed across a   group   sendbuf = address of send buffer   recvbuf = address of receive buffer   count = number of elements in send buffer   datatype = datatype of elements in send buffer   op = reduce operation (only max, min and sum currently supported)   comm = communicator   input: sendbuf, count, datatype, op, comm   output: recvbuflocal data                                                               */   int ierror, i, j, np, rank, id, root = 0, ltmp, loct, nl, lcnt, lsize;   void *tmpbuf;   MPI_Status status;/* internal mpi common block   nproc = number of real or virtual processors obtained   idproc = processor id   mapcomm = communicator map                                            *//* declare common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */   ierror = 0;/* check for error conditions *//* MPI not initialized        */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm < 0) || (comm >= MAXC))      ierror = 2;/* invalid root */   else if ((root < 0) || (root >= nproc))      ierror = 19;/* invalid op */   else if ((op < 0) || (op > 5) || (op==3))      ierror = 20;/* communicator errors */   else {      np = mapcomm[comm][MAXS];      id = mapcomm[comm][root];/* communicator not mapped */      if ((np <= 0) || (np > nproc))         ierror = 2;/* invalid root */      else if ((root < 0) || (root >= np))         ierror = 19;/* invalid mapping */      else if ((id < 0) || (id >= nproc)) {         fprintf(unit2,"Invalid mapping, root, node = %d,%d\n",root,id);         ierror = 2;      }/* get rank */      else {         rank = mapcomm[comm][MAXS+1];         if ((rank >= 0) && (rank < np)) {            if (mapcomm[comm][rank] != idproc)               ierror = 29;         }         else            ierror = 29;      }   }/* handle errors */   if (ierror) {      writerrs("MPI_Scan: ",ierror);      return ierror;   }/* determine size of temporary buffer */   if ((datatype==MPI_INT) || (datatype==MPI_FLOAT))      lsize = 4;   else if (datatype==MPI_DOUBLE)      lsize = 8;   else if ((datatype==MPI_2INT) && ((op==MPI_MAXLOC) || (op==MPI_MINLOC)))      lsize = 8;   else if ((datatype==MPI_FLOAT_INT) && ((op==MPI_MAXLOC) || (op==MPI_MINLOC)))      lsize = 8;   else if ((datatype==MPI_DOUBLE_INT) && ((op==MPI_MAXLOC) || (op==MPI_MINLOC)))      lsize = 16;/* invalid datatype */   else {      ierror = 7;      writerrs("MPI_Scan: ",ierror);      return ierror;   }   loct = 0;   if (rank==root) {/* initialize by copying from send to receive buffer */      if (datatype==MPI_INT)         iredux((int *)recvbuf,(int *)sendbuf,loct,count,-1);      else if (datatype==MPI_FLOAT)         fredux((float *)recvbuf,(float *)sendbuf,loct,count,-1);      else if (datatype==MPI_DOUBLE)         dredux((double *)recvbuf,(double *)sendbuf,loct,count,-1);      else if (datatype==MPI_2INT)         iredux((int *)recvbuf,(int *)sendbuf,loct,2*count,-1);      else if (datatype==MPI_FLOAT_INT)         fredux((float *)recvbuf,(float *)sendbuf,loct,2*count,-1);   }   ltmp = lsize*count;/* allocate a nonrelocatable block of memory */   tmpbuf = NewPtr(ltmp);/* memory not available */   if (!tmpbuf) {      ierror = 21;      writerrs("MPI_Scan: ",ierror);      return ierror;   }   if (monitor==2)      fprintf(unit2,"MPI_Scan started\n");   ltmp = ltmp/lsize;/* send messages in groups of ltmp */   nl = (count - 1)/ltmp + 1;   lcnt = ltmp;   lsize = lsize*ltmp/4;   for (j = 0; j < nl; j++) {/* better check to see if this is OK */      if (j==(nl-1))         lcnt = count - ltmp*(nl - 1);      if (rank==root) {/* root receives data from everyone else */         for (i = 0; i < np; i++) {            if (i != root) {               ierror = MPI_Recv(tmpbuf,lcnt,datatype,i,j+1,comm,&status);/* reduce data */               if (datatype==MPI_INT)                  iredux((int *)recvbuf,(int *)tmpbuf,loct,lcnt,op);               else if (datatype==MPI_FLOAT)                  fredux((float *)recvbuf,(float *)tmpbuf,loct,lcnt,op);               else if (datatype==MPI_DOUBLE)                  dredux((double *)recvbuf,(double *)tmpbuf,loct,lcnt,op);               else if (datatype==MPI_2INT)                  iredux((int *)recvbuf,(int *)tmpbuf,loct,lcnt,op);               else if (datatype==MPI_FLOAT_INT)                  fredux((float *)recvbuf,(float *)tmpbuf,loct,lcnt,op);/* send partial result data to processor i */               ierror = MPI_Send(&((int *)recvbuf)[loct],lcnt,datatype,i,                                 j+nproc+1,comm);            }         }         loct = loct + ltmp;      }      else {/* remaining processors send data to root */         ierror = MPI_Send(&((int *)sendbuf)[loct],lcnt,datatype,root,j+1,comm);/* receive partial result data from root  */         ierror = MPI_Recv(&((int *)recvbuf)[loct],lcnt,datatype,root,j+nproc+1,                           comm,&status);         loct = loct + lsize;      }   }   if (rank==root) {      loct = 0;/* initialize by copying from send to receive buffer */      if (datatype==MPI_INT)         iredux((int *)recvbuf,(int *)sendbuf,loct,count,-1);      else if (datatype==MPI_FLOAT)         fredux((float *)recvbuf,(float *)sendbuf,loct,count,-1);      else if (datatype==MPI_DOUBLE)         dredux((double *)recvbuf,(double *)sendbuf,loct,count,-1);      else if (datatype==MPI_2INT)         iredux((int *)recvbuf,(int *)sendbuf,loct,2*count,-1);      else if (datatype==MPI_FLOAT_INT)         fredux((float *)recvbuf,(float *)sendbuf,loct,2*count,-1);   }/* release nonrelocatable memory block */   DisposePtr((char *)tmpbuf);   if (monitor==2)      fprintf(unit2,"MPI_Scan complete\n");   return ierror;}static int imax(int val1, int val2) {   return (val1 > val2 ? val1 : val2);}     static int imin(int val1, int val2) {   return (val1 < val2 ? val1 : val2);}   static float flmax(float val1, float val2) {   return (val1 > val2 ? val1 : val2);}     static float flmin(float val1, float val2) {   return (val1 < val2 ? val1 : val2);}   static double dmax(double val1, double val2) {   return (val1 > val2 ? val1 : val2);}     static double dmin(double val1, double val2) {   return (val1 < val2 ? val1 : val2);}static void iredux(int *recvbuf, int *sendbuf, int offset, int count, MPI_Op op) {/* perform reduction operation for int types   recvbuf = address of receive buffer   sendbuf = address of send buffer   offset = starting location in receive buffer   count = number of elements in send buffer   op = reduce operation (only max, min and sum currently supported)   input: recvbuf, sendbuf, offset, count, op   output: recvbuflocal data                                                                 */   int i, j, k;/* perform reduction */   if (op==MPI_MAX) {      for (i = 0; i < count; i++) {         recvbuf[i+offset] = imax(recvbuf[i+offset],sendbuf[i]);      }   }   else if (op==MPI_MIN) {      for (i = 0; i < count; i++) {         recvbuf[i+offset] = imin(recvbuf[i+offset],sendbuf[i]);      }   }   else if (op==MPI_SUM) {      for (i = 0; i < count; i++) {         recvbuf[i+offset] = recvbuf[i+offset] + sendbuf[i];      }   }/* perform reduction and location */   else if (op==MPI_MAXLOC) {      for (i = 0; i < count; i++) {         j = recvbuf[2*i+offset];         k = sendbuf[2*i];         if (j < k) {            recvbuf[2*i+offset] = sendbuf[2*i];            recvbuf[2*i+offset+1] = sendbuf[2*i+1];         }         else if (j==k)            recvbuf[2*i+offset+1] = imin(recvbuf[2*i+offset+1],sendbuf[2*i+1]);      }   }   else if (op==MPI_MINLOC) {      for (i = 0; i < count; i++) {         j = recvbuf[2*i+offset];         k = sendbuf[2*i];         if (j > k) {            recvbuf[2*i+offset] = sendbuf[2*i];            recvbuf[2*i+offset+1] = sendbuf[2*i+1];         }         else if (j==k)            recvbuf[2*i+offset+1] = imax(recvbuf[2*i+offset+1],sendbuf[2*i+1]);      }   }/* copy initial data */   else if (op==(-1)) {      for (i = 0; i < count; i++) {         recvbuf[i+offset] = sendbuf[i];      }   }   return;}static void fredux(float *recvbuf, float *sendbuf, int offset, int count, MPI_Op op) {/* perform reduction operation for float types   recvbuf = address of receive buffer   sendbuf = address of send buffer   offset = starting location in receive buffer   count = number of elements in send buffer   op = reduce operation (only max, min and sum currently supported)   input: recvbuf, sendbuf, offset, count, op   output: recvbuflocal data                                                                 */   int i;   float j, k;/* perform reduction */   if (op==MPI_MAX) {      for (i = 0; i < count; i++) {         recvbuf[i+offset] = flmax(recvbuf[i+offset],sendbuf[i]);      }   }   else if (op==MPI_MIN) {      for (i = 0; i < count; i++) {         recvbuf[i+offset] = flmin(recvbuf[i+offset],sendbuf[i]);      }   }   else if (op==MPI_SUM) {      for (i = 0; i < count; i++) {         recvbuf[i+offset] = recvbuf[i+offset] + sendbuf[i];      }   }/* perform reduction and location */   else if (op==MPI_MAXLOC) {      for (i = 0; i < count; i++) {         j = recvbuf[2*i+offset];         k = sendbuf[2*i];         if (j < k) {            recvbuf[2*i+offset] = sendbuf[2*i];            *((int *)&recvbuf[2*i+offset+1]) = *((int *)&sendbuf[2*i+1]);         }         else if (j==k)            *((int *)&recvbuf[2*i+offset+1]) = imin(            *((int *)&recvbuf[2*i+offset+1]),*((int *)&sendbuf[2*i+1]));      }   }   else if (op==MPI_MINLOC) {      for (i = 0; i < count; i++) {         j = recvbuf[2*i+offset];         k = sendbuf[2*i];         if (j > k) {            recvbuf[2*i+offset] = sendbuf[2*i];            *((int *)&recvbuf[2*i+offset+1]) = *((int *)&sendbuf[2*i+1]);         }         else if (j==k)            *((int *)&recvbuf[2*i+offset+1]) = imax(            *((int *)&recvbuf[2*i+offset+1]),*((int *)&sendbuf[2*i+1]));      }   }/* copy initial data */   else if (op==(-1)) {      for (i = 0; i < count; i++) {         recvbuf[i+offset] = sendbuf[i];      }   }   return;}static void dredux(double *recvbuf, double *sendbuf, int offset, int count, MPI_Op op) {/* perform reduction operation for double types   recvbuf = address of receive buffer   sendbuf = address of send buffer   offset = starting location in receive buffer   count = number of elements in send buffer   op = reduce operation (only max, min and sum currently supported)   input: recvbuf, sendbuf, offset, count, op   output: recvbuflocal data                                                                 */   int i;   double j, k;/* perform reduction */   if (op==MPI_MAX) {      for (i = 0; i < count; i++) {         recvbuf[i+offset] = dmax(recvbuf[i+offset],sendbuf[i]);      }   }   else if (op==MPI_MIN) {      for (i = 0; i < count; i++) {         recvbuf[i+offset] = dmin(recvbuf[i+offset],sendbuf[i]);      }   }   else if (op==MPI_SUM) {      for (i = 0; i < count; i++) {         recvbuf[i+offset] = recvbuf[i+offset] + sendbuf[i];      }   }/* perform reduction and location */   else if (op==MPI_MAXLOC) {      for (i = 0; i < count; i++) {         j = recvbuf[2*i+offset];         k = sendbuf[2*i];         if (j < k) {            recvbuf[2*i+offset] = sendbuf[2*i];            *((int *)&recvbuf[2*i+offset+1]) = *((int *)&sendbuf[2*i+1]);         }         else if (j==k)            *((int *)&recvbuf[2*i+offset+1]) = imin(            *((int *)&recvbuf[2*i+offset+1]),*((int *)&sendbuf[2*i+1]));      }   }   else if (op==MPI_MINLOC) {      for (i = 0; i < count; i++) {         j = recvbuf[2*i+offset];         k = sendbuf[2*i];         if (j > k) {            recvbuf[2*i+offset] = sendbuf[2*i];            *((int *)&recvbuf[2*i+offset+1]) = *((int *)&sendbuf[2*i+1]);         }         else if (j==k)            *((int *)&recvbuf[2*i+offset+1]) = imax(            *((int *)&recvbuf[2*i+offset+1]),*((int *)&sendbuf[2*i+1]));      }   }/* copy initial data */   else if (op==(-1)) {      for (i = 0; i < count; i++) {         recvbuf[i+offset] = sendbuf[i];      }   }   return;}int MPI_Allreduce(void* sendbuf, void* recvbuf, int count,                  MPI_Datatype datatype, MPI_Op op, MPI_Comm comm) {/* applies a reduction operation to the vector sendbuf over the set of   processes specified by comm and places result in recvbuf on all nodes   sendbuf = address of send buffer   recvbuf = address of receive buffer   count = number of elements in send buffer   datatype = datatype of elements in send buffer   op = reduce operation (only max, min and sum currently supported)   comm = communicator   input: sendbuf, count, datatype, op, root, comm   output: recvbuflocal data                                                               */   int ierror, root = 0, ierr;/* declare common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */   if (monitor==2)      fprintf(unit2,"MPI_Allreduce started\n");   ierror = MPI_Reduce(sendbuf,recvbuf,count,datatype,op,root,comm);   ierr = MPI_Bcast(recvbuf,count,datatype,root,comm);   if (monitor==2)      fprintf(unit2,"MPI_Allreduce complete\n");   return ierror;}int MPI_Gather(void* sendbuf, int sendcount, MPI_Datatype sendtype,               void* recvbuf, int recvcount, MPI_Datatype recvtype,               int root, MPI_Comm comm) {/* collect individual messages from each process in comm at root   sendbuf = starting address of send buffer   sendcount = number of elements in send buffer   sendtype = datatype of send buffer elements   recvbuf = address of receive buffer   recvcount = number of elements for any single receive   recvtype = datatype of recv buffer elements   root = rank of receiving process   comm = communicator   input: sendbuf, sendcount, sendtype, recvcount, recvtype, root, comm   output: recvbuflocal data                                                               */   int ierror, np, loct, lsize, id, rank, i, j;   MPI_Status status;/* internal mpi common block   nproc = number of real or virtual processors obtained   idproc = processor id   mapcomm = communicator map                                            *//* declare common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */   ierror = 0;/* check for error conditions *//* MPI not initialized        */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm < 0) || (comm >= MAXC))      ierror = 2;/* invalid root */   else if ((root < 0) || (root >= nproc))      ierror = 19;/* invalid count */   else if (sendcount < 0)      ierror = 3;/* communicator errors */   else {      np = mapcomm[comm][MAXS];      id = mapcomm[comm][root];/* communicator not mapped */      if ((np <= 0) || (np > nproc))         ierror = 2;/* invalid root */      else if ((root < 0) || (root >= np))         ierror = 19;/* invalid mapping */      else if ((id < 0) || (id >= nproc)) {         fprintf(unit2,"Invalid mapping, root, node = %d,%d\n",root,id);         ierror = 2;      }/* get rank */      else {         rank = mapcomm[comm][MAXS+1];         if ((rank >= 0) && (rank < np)) {            if (mapcomm[comm][rank] != idproc)               ierror = 29;         }         else            ierror = 29;      }   }/* handle errors */   if (ierror) {      writerrs("MPI_Gather: ",ierror);      return ierror;   }/* root receives data */   if (rank==root) {/* invalid count */      if (recvcount < 0)         ierror = 3;/* determine size of data to be sent */      if ((sendtype==MPI_INT) || (sendtype==MPI_FLOAT))         loct = sendcount;      else if (sendtype==MPI_DOUBLE)         loct = 2*sendcount;/* invalid datatype */      else {         loct = 0;         ierror = 7;      }/* determine size of data to be received */      if ((recvtype==MPI_INT) || (recvtype==MPI_FLOAT))         lsize = recvcount;      else if (recvtype==MPI_DOUBLE)         lsize = 2*recvcount;/* invalid datatype */      else {         lsize = 0;         ierror = 7;      }/* unequal message length error */      if (loct != lsize) {         fprintf(unit2,"Unequal message length, send/receive bytes = %d,%d\n",                loct,lsize);         ierror = 22;      }/* handle count, datatype and length errors */      if (ierror) {         writerrs("MPI_Gather: ",ierror);         return ierror;      }      if (monitor==2)         fprintf(unit2,"MPI_Gather started\n");      for (i = 0; i < np; i++) {         loct = lsize*i;/* root copies its own data directly */         if (i==root) {            for (j = 0; j < lsize; j++)               ((int *)recvbuf)[j+loct] = ((int *)sendbuf)[j];         }/* otherwise, root receives data from other processors */         else            ierror = MPI_Recv(&((int *)recvbuf)[loct],recvcount,recvtype,i,1,comm,                              &status);      }   }/* processors other than root send data to root */   else {      if (monitor==2)         fprintf(unit2,"MPI_Gather started\n");      ierror = MPI_Send(sendbuf,sendcount,sendtype,root,1,comm);   }   if (monitor==2)         fprintf(unit2,"MPI_Gather complete\n");   return ierror;}int MPI_Allgather(void* sendbuf, int sendcount,                  MPI_Datatype sendtype, void* recvbuf, int recvcount,                  MPI_Datatype recvtype, MPI_Comm comm) {/* gather individual messages from each process in comm and distribute   the resulting message to each process.   sendbuf = starting address of send buffer   sendcount = number of elements in send buffer   sendtype = datatype of send buffer elements   recvbuf = address of receive buffer   recvcount = number of elements for any process   recvtype = datatype of receive buffer elements   comm = communicator   input: sendbuf, sendcount, sendtype, recvcount, recvtype, comm   output: recvbuflocal data                                                               */   int ierror, np, root = 0, ierr;/* internal mpi common block   mapcomm = communicator map                                            *//* declare common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */   if (monitor==2)      fprintf(unit2,"MPI_Allgather started\n");   ierror = MPI_Gather(sendbuf,sendcount,sendtype,recvbuf,recvcount,recvtype,                       root,comm);   np = mapcomm[comm][MAXS];   ierr = MPI_Bcast(recvbuf,np*recvcount,recvtype,root,comm);   if (monitor==2)      fprintf(unit2,"MPI_Allgather complete\n");   return ierror;}int MPI_Scatter(void* sendbuf, int sendcount, MPI_Datatype sendtype,                void* recvbuf, int recvcount, MPI_Datatype recvtype,                int root, MPI_Comm comm) {/* distribute individual messages from root to each process in comm   sendbuf = starting address of send buffer   sendcount = number of elements in send buffer   sendtype = datatype of send buffer elements   recvbuf = address of receive buffer   recvcount = number of elements for any single receive   recvtype = datatype of recv buffer elements   root = rank of sending process   comm = communicator   input: sendbuf, sendcount, sendtype, recvcount, recvtype, root, comm   output: recvbuflocal data                                                               */   int ierror, np, lsize, loct, id, rank, i, j;   MPI_Status status;/* internal mpi common block   nproc = number of real or virtual processors obtained   idproc = processor id   mapcomm = communicator map                                            *//* declare common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */   ierror = 0;/* check for error conditions *//* MPI not initialized        */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm < 0) || (comm >= MAXC))      ierror = 2;/* invalid root */   else if ((root < 0) || (root >= nproc))      ierror = 19;/* invalid count */   else if (recvcount < 0)      ierror = 3;/* communicator errors */   else {      np = mapcomm[comm][MAXS];      id = mapcomm[comm][root];/* communicator not mapped */      if ((np <= 0) || (np > nproc))         ierror = 2;/* invalid root */      else if ((root < 0) || (root >= np))         ierror = 19;/* invalid mapping */      else if ((id < 0) || (id >= nproc)) {         fprintf(unit2,"Invalid mapping, root, node = %d,%d\n",root,id);         ierror = 2;      }/* get rank */      else {         rank = mapcomm[comm][MAXS+1];         if ((rank >= 0) && (rank < np)) {            if (mapcomm[comm][rank] != idproc)               ierror = 29;         }         else            ierror = 29;      }   }/* handle errors */   if (ierror) {      writerrs("MPI_Scatter: ",ierror);      return ierror;   }/* root sends data */   if (rank==root) {/* invalid counts */      if (sendcount < 0)         ierror = 3;/* determine size of data to be sent */      if ((sendtype==MPI_INT) || (sendtype==MPI_FLOAT))         lsize = sendcount;      else if (sendtype==MPI_DOUBLE)         lsize = 2*sendcount;/* invalid datatype */      else {         lsize = 0;         ierror = 7;      }/* determine size of data to be received */      if ((recvtype==MPI_INT) || (recvtype==MPI_FLOAT))         loct = recvcount;      else if (recvtype==MPI_DOUBLE)         loct = 2*recvcount;/* invalid datatype */      else {         loct = 0;         ierror = 7;      }/* unequal message length error */      if (loct != lsize) {         fprintf(unit2,"Unequal message length, send/receive bytes = %d,%d\n",                lsize,loct);         ierror = 22;      }/* handle count, datatype and length errors */      if (ierror) {         writerrs("MPI_Scatter: ",ierror);         return ierror;      }      if (monitor==2)         fprintf(unit2,"MPI_Scatter started\n");      for (i = 0; i < np; i++) {         loct = lsize*i;/* root copies its own data directly */         if (i==root) {            for (j = 0; j < lsize; j++)              ((int *)recvbuf)[j] = ((int *)sendbuf)[j+loct];         }/* otherwise, root sends data to other processors */         else            ierror = MPI_Send(&((int *)sendbuf)[loct],sendcount,sendtype,i,1,comm);      }   }/* processors other than root receive data from root */   else {      if (monitor==2)         fprintf(unit2,"MPI_Scatter started\n");      ierror = MPI_Recv(recvbuf,recvcount,recvtype,root,1,comm,&status);   }   if (monitor==2)      fprintf(unit2,"MPI_Scatter complete\n");   return ierror;}int MPI_Alltoall(void* sendbuf, int sendcount, MPI_Datatype sendtype,                 void* recvbuf, int recvcount, MPI_Datatype recvtype,                 MPI_Comm comm) {/* send a distinct message from each process to every process   sendbuf = starting address of send buffer   sendcount = number of elements in send buffer   sendtype = datatype of send buffer elements   recvbuf = address of receive buffer   recvcount = number of elements for any single receive   recvtype = datatype of recv buffer elements   comm = communicator   input: sendbuf, sendcount, sendtype, recvcount, recvtype, comm   output: recvbuflocal data                                                               */   int ierror, np, loct, lsize, id, rank, i, j;   MPI_Request request;   MPI_Status status;/* internal mpi common block   nproc = number of real or virtual processors obtained   idproc = processor id   mapcomm = communicator map                                            *//* declare common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */   ierror = 0;/* check for error conditions *//* MPI not initialized        */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm < 0) || (comm >= MAXC))      ierror = 2;/* invalid counts */   else if ((sendcount < 0) || (recvcount < 0))      ierror = 3;/* communicator errors */   else {      np = mapcomm[comm][MAXS];/* communicator not mapped */      if ((np <= 0) || (np > nproc))         ierror = 2;/* get rank */      else {         rank = mapcomm[comm][MAXS+1];         if ((rank >= 0) && (rank < np)) {            if (mapcomm[comm][rank] != idproc)               ierror = 29;         }         else            ierror = 29;      }   }/* handle errors */   if (ierror) {      writerrs("MPI_Alltoall: ",ierror);      return ierror;   }/* determine size of data to be sent */   if ((sendtype==MPI_INT) || (sendtype==MPI_FLOAT))      loct = sendcount;   else if (sendtype==MPI_DOUBLE)      loct = 2*sendcount;/* invalid datatype */   else {      loct = 0;      ierror = 7;   }/* determine size of data to be received */   if ((recvtype==MPI_INT) || (recvtype==MPI_FLOAT))      lsize = recvcount;   else if (recvtype==MPI_DOUBLE)      lsize = 2*recvcount;/* invalid datatype */   else {      lsize = 0;      ierror = 7;   }/* unequal message length error */   if (loct != lsize) {      fprintf(unit2,"Unequal message length, send/receive bytes = %d,%d\n",             loct,lsize);      ierror = 22;   }/* handle count, datatype and length errors */   if (ierror) {      writerrs("MPI_Alltoall: ",ierror);      return ierror;   }   if (monitor==2)      fprintf(unit2,"MPI_Alltoall started\n");   for (i = 0; i < np; i++) {      id = i - rank;      if (id < 0)         id += np;      loct = lsize*id;/* each node copies its own data directly */      if (rank==id) {         for (j = 0; j < lsize; j++)            ((int *)recvbuf)[j+loct] = ((int *)sendbuf)[j+loct];      }/* otherwise, each node receives data from other nodes */      else {         ierror = MPI_Irecv(&((int *)recvbuf)[loct],recvcount,recvtype,id,i+1,comm,                            &request) ;         ierror = MPI_Send(&((int *)sendbuf)[loct],sendcount,sendtype,id,i+1,comm);         ierror = MPI_Wait(&request,&status);      }   }   if (monitor==2)      fprintf(unit2,"MPI_Alltoall complete\n");   return ierror;}int MPI_Gatherv(void* sendbuf, int sendcount, MPI_Datatype sendtype,                void* recvbuf, int *recvcounts, int *displs,                MPI_Datatype recvtype, int root, MPI_Comm comm) {/* collect individual messages from each process in comm at root   messages can have different sizes and displacements   sendbuf = starting address of send buffer   sendcount = number of elements in send buffer   sendtype = datatype of send buffer elements   recvbuf = address of receive buffer   recvcounts = integer array   displs = integer array of displacements   recvtype = datatype of recv buffer elements   root = rank of receiving process   comm = communicator   input: sendbuf, sendcount, sendtype, recvcounts, displs, recvtype   input: root, comm   output: recvbuflocal data                                                               */   int ierror, np, loct, lsize, id, rank, i, j;   MPI_Status status;/* internal mpi common block   nproc = number of real or virtual processors obtained   idproc = processor id   mapcomm = communicator map                                            *//* declare common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */   ierror = 0;/* check for error conditions *//* MPI not initialized        */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm < 0) || (comm >= MAXC))      ierror = 2;/* invalid root */   else if ((root < 0) || (root >= nproc))      ierror = 19;/* invalid count */   else if (sendcount < 0)      ierror = 3;/* communicator errors */   else {      np = mapcomm[comm][MAXS];      id = mapcomm[comm][root];/* communicator not mapped */      if ((np <= 0) || (np > nproc))         ierror = 2;/* invalid root */      else if ((root < 0) || (root >= np))         ierror = 19;/* invalid mapping */      else if ((id < 0) || (id >= nproc)) {         fprintf(unit2,"Invalid mapping, root, node = %d,%d\n",root,id);         ierror = 2;      }/* get rank */      else {         rank = mapcomm[comm][MAXS+1];         if ((rank >= 0) && (rank < np)) {            if (mapcomm[comm][rank] != idproc)               ierror = 29;         }         else            ierror = 29;      }   }/* handle errors */   if (ierror) {      writerrs("MPI_Gatherv: ",ierror);      return ierror;   }/* root receives data */   if (rank==root) {/* invalid counts */      for (i = 0; i < np; i++) {         if (recvcounts[i] < 0)            ierror = 3;      }/* determine size of data to be sent */      if ((sendtype==MPI_INT) || (sendtype==MPI_FLOAT))         loct = 1;      else if (sendtype==MPI_DOUBLE)         loct = 2;/* invalid datatype */      else {         ierror = 7;      }/* determine size of data to be received */      if ((recvtype==MPI_INT) || (recvtype==MPI_FLOAT))         lsize = 1;      else if (recvtype==MPI_DOUBLE)         lsize = 2;/* invalid datatype */      else {         ierror = 7;      }/* unequal message length error */      id = lsize*recvcounts[rank];      if ((!ierror) && (loct*sendcount != id)) {         fprintf(unit2,"Unequal self message, send/receive bytes = %d,%d\n",                loct*sendcount,id);         ierror = 22;      }/* handle count, datatype and length errors */      if (ierror) {         writerrs("MPI_Gatherv: ",ierror);         return ierror;      }      if (monitor==2)         fprintf(unit2,"MPI_Gatherv started\n");      for (i = 0; i < np; i++) {         loct = lsize*displs[i];/* root copies its own data directly */         if (i==root) {            for (j = 0; j < lsize*recvcounts[i]; j++)               ((int *)recvbuf)[j+loct] = ((int *)sendbuf)[j];         }/* otherwise, root receives data from other processors */         else {            if (monitor==2)               fprintf(unit2,"MPI_Gatherv started\n");            ierror = MPI_Recv(&((int *)recvbuf)[loct],recvcounts[i],recvtype,                              i,1,comm,&status);         }      }   }/* processors other than root send data to root */   else      ierror = MPI_Send(sendbuf,sendcount,sendtype,root,1,comm);   if (monitor==2)      fprintf(unit2,"MPI_Gatherv complete\n");   return ierror;}int MPI_Allgatherv(void* sendbuf, int sendcount,                   MPI_Datatype sendtype, void* recvbuf, int *recvcounts,                   int *displs, MPI_Datatype recvtype, MPI_Comm comm) {/* gather individual messages from each process in comm and distribute   the resulting message to each process.   messages can have different sizes and displacements   sendbuf = starting address of send buffer   sendcount = number of elements in send buffer   sendtype = datatype of send buffer elements   recvbuf = address of receive buffer   recvcounts = integer array   displs = integer array of displacements   recvtype = datatype of receive buffer elements   comm = communicator   input: sendbuf, sendcount, sendtype, recvcounts, displs, recvtype   input: comm   output: recvbuflocal data                                                               */   int ierror, np, i, ierr;/* internal mpi common block   nproc = number of real or virtual processors obtained   mapcomm = communicator map                                            *//* declare common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */   ierror = 0;/* communicator errors */   if ((comm >= 0) && (comm < MAXC)) {      np = mapcomm[comm][MAXS];      if ((np <= 0) || (np > nproc))         ierror = 2;   }   else      ierror = 2;/* handle errors */   if (ierror) {      writerrs("MPI_Allgatherv: ",ierror);      return ierror;   }   if (monitor==2)      fprintf(unit2,"MPI_Allgatherv started\n");   for (i = 0; i < np; i++) {      ierr = MPI_Gatherv(sendbuf,sendcount,sendtype,recvbuf,recvcounts,displs,                         recvtype,i,comm);      if (ierr)         ierror = ierr;   }   if (monitor==2)      fprintf(unit2,"MPI_Allgatherv complete\n");   return ierror;}int MPI_Scatterv(void* sendbuf, int *sendcounts, int *displs,                 MPI_Datatype sendtype, void* recvbuf, int recvcount,                 MPI_Datatype recvtype, int root, MPI_Comm comm) {/* distribute individual messages from root to each process in comm   messages can have different sizes and displacements   sendbuf = starting address of send buffer   sendcounts = integer array   displs = integer array of displacements   sendtype = datatype of send buffer elements   recvbuf = address of receive buffer   recvcount = number of elements for any single receive   recvtype = datatype of recv buffer elements   root = rank of sending process   comm = communicator   input: sendbuf, sendcounts, displs, sendtype, recvcount, recvtype   input: root, comm   output: recvbuflocal data                                                               */   int ierror, np, lsize, loct, id, rank, i, j;   MPI_Status status;/* internal mpi common block   nproc = number of real or virtual processors obtained   idproc = processor id   mapcomm = communicator map                                            *//* declare common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */   ierror = 0;/* check for error conditions *//* MPI not initialized        */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm < 0) || (comm >= MAXC))      ierror = 2;/* invalid root */   else if ((root < 0) || (root >= nproc))      ierror = 19;/* invalid counts */   else if (recvcount < 0)      ierror = 3;/* communicator errors */   else {      np = mapcomm[comm][MAXS];      id = mapcomm[comm][root];/* communicator not mapped */      if ((np <= 0) || (np > nproc))         ierror = 2;/* invalid root */      else if ((root < 0) || (root >= np))         ierror = 19;/* invalid mapping */      else if ((id < 0) || (id >= nproc)) {         fprintf(unit2,"Invalid mapping, root, node = %d,%d\n",root,id);         ierror = 2;      }/* get rank */      else {         rank = mapcomm[comm][MAXS+1];         if ((rank >= 0) && (rank < np)) {            if (mapcomm[comm][rank] != idproc)               ierror = 29;         }         else            ierror = 29;      }   }/* handle errors */   if (ierror) {      writerrs("MPI_Scatterv: ",ierror);      return ierror;   }/* root sends data */   if (rank==root) {/* invalid counts */      for (i = 0; i < np; i++) {         if (sendcounts[i] < 0)            ierror = 3;      }/* determine size of data to be sent */      if ((sendtype==MPI_INT) || (sendtype==MPI_FLOAT))         lsize = 1;      else if (sendtype==MPI_DOUBLE)         lsize = 2;/* invalid datatype */      else {         ierror = 7;      }/* determine size of data to be received */      if ((recvtype==MPI_INT) || (recvtype==MPI_FLOAT))         loct = 1;      else if (recvtype==MPI_DOUBLE)         loct = 2;/* invalid datatype */      else {         ierror = 7;      }/* unequal message length error */      id = lsize*sendcounts[rank];      if ((!ierror) && (loct*recvcount != id)) {         fprintf(unit2,"Unequal self message, send/receive bytes = %d,%d\n",                id,loct*recvcount);         ierror = 22;      }/* handle count, datatype and length errors */      if (ierror) {         writerrs("MPI_Scatterv: ",ierror);         return ierror;      }      if (monitor==2)         fprintf(unit2,"MPI_Scatterv started\n");      for (i = 0; i < np; i++) {         loct = lsize*displs[i];/* root copies its own data directly */         if (i==root) {            for (j = 0; j < lsize*sendcounts[i]; j++)              ((int *)recvbuf)[j] = ((int *)sendbuf)[j+loct];         }/* otherwise, root sends data to other processors */         else            ierror = MPI_Send(&((int *)sendbuf)[loct],sendcounts[i],sendtype,                              i,1,comm);      }   }/* processors other than root receive data from root */   else {      if (monitor==2)         fprintf(unit2,"MPI_Scatterv started\n");      ierror = MPI_Recv(recvbuf,recvcount,recvtype,root,1,comm,&status);   }   if (monitor==2)      fprintf(unit2,"MPI_Scatterv complete\n");   return ierror;}int MPI_Alltoallv(void* sendbuf, int *sendcounts, int *sdispls,                  MPI_Datatype sendtype, void* recvbuf, int *recvcounts,                  int *rdispls, MPI_Datatype recvtype, MPI_Comm comm) {/* send a distinct message from each process to every process   messages can have different sizes and displacements   sendbuf = starting address of send buffer   sendcounts = integer array   sdispls = integer array of send displacements   sendtype = datatype of send buffer elements   recvbuf = address of receive buffer   recvcounts = integer array   rdispls = integer array of receive displacements   recvtype = datatype of recv buffer elements   comm = communicator   input: sendbuf, sendcount, sendtype, recvcount, recvtype, comm   output: recvbuflocal data                                                               */   int ierror, np, locs, msize, loct, lsize, id, ld, rank, i, j;   MPI_Request request;   MPI_Status status;/* internal mpi common block   nproc = number of real or virtual processors obtained   idproc = processor id   mapcomm = communicator map                                            *//* declare common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */   ierror = 0;/* check for error conditions *//* MPI not initialized        */   if (nproc <= 0)      ierror = 1;/* invalid comm */   else if ((comm < 0) || (comm >= MAXC))      ierror = 2;/* communicator errors */   else {      np = mapcomm[comm][MAXS];/* communicator not mapped */      if ((np <= 0) || (np > nproc))         ierror = 2;/* get rank */      else {         rank = mapcomm[comm][MAXS+1];         if ((rank >= 0) && (rank < np)) {            if (mapcomm[comm][rank] != idproc)               ierror = 29;         }         else            ierror = 29;      }   }/* invalid counts */   for (i = 0; i < np; i++) {      if ((sendcounts[i] < 0) || (recvcounts[i] < 0))         ierror = 3;   }/* handle errors */   if (ierror) {      writerrs("MPI_Alltoallv: ",ierror);      return ierror;   }/* determine size of data to be sent */   if ((sendtype==MPI_INT) || (sendtype==MPI_FLOAT))      msize = 1;   else if (sendtype==MPI_DOUBLE)      msize = 2;/* invalid datatype */   else {      ierror = 7;   }/* determine size of data to be received */   if ((recvtype==MPI_INT) || (recvtype==MPI_FLOAT))      lsize = 1;   else if (recvtype==MPI_DOUBLE)      lsize = 2;/* invalid datatype */   else {      ierror = 7;   }/* unequal message length error */   id = msize*sendcounts[rank];   ld = lsize*recvcounts[rank];   if ((!ierror) && (id != ld)) {      fprintf(unit2,"Unequal self message length, send/receive bytes = %d,%d\n",             id,ld);      ierror = 22;   }/* handle count, datatype and length errors */   if (ierror) {      writerrs("MPI_Alltoallv: ",ierror);      return ierror;   }   if (monitor==2)      fprintf(unit2,"MPI_Alltoallv started\n");   for (i = 0; i < np; i++) {      id = i - rank;      if (id < 0)         id += np;      locs = msize*sdispls[id];      loct = lsize*rdispls[id];/* each node copies its own data directly */      if (rank==id) {         for (j = 0; j < lsize*recvcounts[id]; j++)            ((int *)recvbuf)[j+loct] = ((int *)sendbuf)[j+locs];      }/* otherwise, each node receives data from other nodes */      else {         ierror = MPI_Irecv(&((int *)recvbuf)[loct],recvcounts[id],recvtype,id,                            i+1,comm,&request) ;         ierror = MPI_Send(&((int *)sendbuf)[locs],sendcounts[id],sendtype,id,                           i+1,comm);         ierror = MPI_Wait(&request,&status);      }   }   if (monitor==2)      fprintf(unit2,"MPI_Alltoallv complete\n");   return ierror;}int MPI_Reduce_scatter(void* sendbuf, void* recvbuf, int *recvcounts,                       MPI_Datatype datatype, MPI_Op op, MPI_Comm comm) {/* applies a reduction operation to the vector sendbuf over the set of   processes specified by comm and scatters the result according to the   values in recvcounts   sendbuf = starting address of send buffer   recvbuf = starting address of receive buffer   recvcounts = integer array   datatype = datatype of elements in input buffer   op = reduce operation (only max, min and sum currently supported)   comm = communicator   input: sendbuf, recvcounts, datatype, op, comm   output: recvbuflocal data                                                               */   int ierror, np, rank, root = 0, count, lsize, ltmp, i;   int *displs;   void *tmpbuf;/* internal mpi common block   nproc = number of real or virtual processors obtained   idproc = processor id   mapcomm = communicator map                                            *//* declare common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */   ierror = 0;/* invalid comm */   if ((comm < 0) || (comm >= MAXC))      ierror = 2;/* communicator errors */   else {      np = mapcomm[comm][MAXS];/* communicator not mapped */      if ((np <= 0) || (np > nproc))         ierror = 2;/* get rank */      else {         rank = mapcomm[comm][MAXS+1];         if ((rank >= 0) && (rank < np)) {            if (mapcomm[comm][rank] != idproc)               ierror = 29;         }         else            ierror = 29;      }   }/* handle errors */   if (ierror) {      writerrs("MPI_Reduce_scatter: ",ierror);      return ierror;   }   ltmp = 4*np;/* allocate a nonrelocatable block of memory */   displs = (int *)NewPtr(ltmp);/* memory not available */   if (!displs) {      ierror = 21;      writerrs("MPI_Reduce_scatter: ",ierror);      return ierror;   }   count = 0;/* determines overall count and displacements */   for (i = 0; i < np; i++) {      displs[i] = count;      count = count + recvcounts[i];   }/* determine size of temporary buffer */   if ((datatype==MPI_INT) || (datatype==MPI_FLOAT))      lsize = 4;   else if (datatype==MPI_DOUBLE)      lsize = 8;   else if ((datatype==MPI_2INT) && ((op==MPI_MAXLOC) || (op==MPI_MINLOC)))      lsize = 8;   else if ((datatype==MPI_FLOAT_INT) && ((op==MPI_MAXLOC) || (op==MPI_MINLOC)))      lsize = 8;   else if ((datatype==MPI_DOUBLE_INT) && ((op==MPI_MAXLOC) || (op==MPI_MINLOC)))      lsize = 16;/* invalid datatype */   else {      ierror = 7;      writerrs("MPI_Reduce_scatter: ",ierror);      return ierror;   }   if (monitor==2)      fprintf(unit2,"MPI_Reduce_scatter started\n");   ltmp = lsize*count;/* allocate a nonrelocatable block of memory */   tmpbuf = NewPtr(ltmp);/* memory not available */   if (!tmpbuf) {      ierror = 21;      writerrs("MPI_Reduce_scatter: ",ierror);      return ierror;   }   ierror = MPI_Reduce(sendbuf,tmpbuf,count,datatype,op,root,comm);   ierror = MPI_Scatterv(tmpbuf,recvcounts,displs,datatype,recvbuf,                         recvcounts[rank],datatype,root,comm);/* release nonrelocatable memory block */   DisposePtr((char *)tmpbuf);/* release nonrelocatable memory block */   DisposePtr((char *)displs);   if (monitor==2)      fprintf(unit2,"MPI_Reduce_scatter complete\n");   return ierror;}int MPI_Abort(MPI_Comm comm, int errorcode) {/* force all tasks on an MPI environment to terminate   comm = communicator   errorcode = error code to return to invoking environment   input: comm, errorcodelocal data                                                              */   int ierror;/* internal mpi common block   nproc = number of real or virtual processors obtained                *//* MPI not initialized        */   if (nproc <= 0)      ierror = 1;/* this is just a temporary patch, have not yet notified everyone else  */   else      ierror = MPI_Finalize();   return ierror;}double MPI_Wtime(void) {/* return an elapsed time on the calling processor in seconds */   const double tick=1.0/1000.0;/* internal mpi common block   stime = first time stamp if MPI_Init successful *//* calculate time elapsed in milliseconds */   return (double) (OTElapsedMilliseconds(&stime))*tick;}double MPI_Wtick(void) {/* return the resolution of MPI_Wtime in seconds */   const double tick=1.0/1000.0;   return tick;}int MPI_Type_extent(MPI_Datatype datatype, MPI_Aint *extent) {/* returns the size of a datatype   datatype = datatype   extent = datatype extent   input: dataype   output: extentlocal data                                                              */   int ierror;   ierror = 0;/* find size of datatype */   if ((datatype==MPI_INT) || (datatype==MPI_FLOAT))      *extent = 4;   else if (datatype==MPI_DOUBLE)      *extent = 8;   else if (datatype==MPI_BYTE)      *extent = 1;   else if ((datatype==MPI_2INT) || (datatype==MPI_FLOAT_INT))       *extent = 8;   else if (datatype==MPI_DOUBLE_INT)      *extent = 16;/* invalid datatype */   else {      ierror = 7;      fprintf(unit2,"MPI_Type_extent: Invalid datatype\n");   }   return ierror;}int MPI_Get_processor_name(char *name,int *resultlen) {/* returns the name of the processor on which it was called   name = a unique specifier for the current physical node   resultlen = length of the result returned in name   input: none   output: name, resultlen  local data                                                  */   int ierror, nv;   InetInterfaceInfo info;   long oss;   char myself[18], ename[8];/* declare internal mpi common block   idproc = processor id              */   ierror = 0;/* Convert processor id to printable integer */   sprintf(ename,"%d",idproc);/* Obtain information about the Internet environment */   oss = OTInetGetInterfaceInfo(&info,kDefaultInetInterface);   if (oss) {      ierror = oss;      fprintf(unit2,"MPI_Get_processor_name: GetInterfaceInfo Error");      return ierror;   }   OTInetHostToString(info.fAddress,myself);   strcat(myself,":");   strcat(myself,ename);   nv = imin(strlen(myself),MPI_MAX_PROCESSOR_NAME);   strncpy(name,myself,nv+1);   *resultlen = nv;   return ierror;}void writerrs(char *source, int ierror) {/* this subroutine writes out error descriptions from error codes   source = source subroutine of error message   ierror = error indicator   input: source, ierrorlocal data                                                         */   int ierr, fatal=1;/* check error code and print corresponding message */   if (ierror==1)      fprintf(unit2,"%s MPI not initialized\n",source);   else if (ierror==2)      fprintf(unit2,"%s Invalid Communicator\n",source);   else if (ierror==3)      fprintf(unit2,"%s Invalid count\n",source);   else if (ierror==4)      fprintf(unit2,"%s Invalid destination\n",source);   else if (ierror==5)      fprintf(unit2,"%s Invalid source\n",source);   else if (ierror==6)      fprintf(unit2,"%s Invalid tag\n",source);   else if (ierror==7)      fprintf(unit2,"%s Invalid datatype\n",source);   else if (ierror==12)      fprintf(unit2,"%s Incomplete read\n",source);   else if (ierror==16)      fprintf(unit2,"%s Invalid request handle\n",source);   else if (ierror==18)      fprintf(unit2,"%s Mismatched dataype\n",source);   else if (ierror==19)      fprintf(unit2,"%s Invalid root\n",source);   else if (ierror==20)      fprintf(unit2,"%s Invalid operation\n",source);   else if (ierror==21)      fprintf(unit2,"%s Unable to allocate memory\n",source);   else if (ierror==29)      fprintf(unit2,"%s Invalid rank or communicator\n",source);   else if (ierror==(-1))      fprintf(unit2,"%s Orderly disconnect request received\n",source);   else if (ierror==(-2))      fprintf(unit2,"%s Disorderly disconnect request received\n",source);   else if (ierror==(-3))      fprintf(unit2,"%s Unexpected flag returned on OTRcv\n",source);/* unlisted error code */   else      fprintf(unit2,"%s Error code = %d\n",source,ierror);/* abort if error is fatal */   if (fatal) {      fflush(unit2);      ierr = MPI_Abort(MPI_COMM_WORLD,ierror);      exit(0);   }}void rwstat(int request, FILE *unit) {/* this subroutine writes out the status of a read-write record   request = request handle   unit = output file pointer   input: request, unit                                         *//* internal common block for non-blocking messages   rwrec = read/write record for asynchronous messages *//* invalid request handle */   if ((request < 0) || (request >= MAXM))      return;   fprintf(unit,"\n");   if (curreq[request][0]==(-1))      fprintf(unit," transmission mode = send\n");   else if (curreq[request][0]==1)      fprintf(unit," transmission mode = receive\n");   fprintf(unit," destination/source = %d\n",curreq[request][1]);   fprintf(unit," communicator = %d\n",curreq[request][2]);   fprintf(unit," tag = %d\n",curreq[request][3]);   fprintf(unit," datatype = %d\n",curreq[request][4]);   fprintf(unit," request handle = %d\n",request);   fprintf(unit," Endpoint reference pointer = %p\n",rwrec[request].ref);   fprintf(unit," iocompletion flag = %d\n",rwrec[request].ioflag);   fprintf(unit," current buffer pointer = %p\n",rwrec[request].buf);   fprintf(unit," current buffer length = %d\n",rwrec[request].nbytes);   fprintf(unit," T_MORE flag = %d\n",rwrec[request].flags);   fprintf(unit," data pointer = %p\n",rwrec[request].sbuf);   fprintf(unit," data length = %d\n",rwrec[request].sln);   fprintf(unit," actual length sent/received = %d\n",rwrec[request].len);   fprintf(unit," first time stamp = %d,%d\n",rwrec[request].ts[0].hi,           rwrec[request].ts[0].lo);   fprintf(unit," second time stamp = %d,%d\n",rwrec[request].ts[1].hi,           rwrec[request].ts[1].lo);   fprintf(unit," next message pointer = %d\n",rwrec[request].nextm);   fprintf(unit," non-fatal error code = %d\n",rwrec[request].nfatal);   fprintf(unit,"\n");   return;}void wqueue(FILE *unit) {/* this subroutine writes queue of pending messages    unit = output file pointer   input: iunitlocal data                                                */   int i, is = 0;/* internal mpi common block   nproc = number of real or virtual processors obtained   idproc = processor id   ioc = array of context pointers for notifier function  *//* internal common block for non-blocking messages   mqueue = message request queue                         */   for (i = 0; i < nproc; i++) {      if (ioc[i][2]) {         fprintf(unit,"Incomplete receive: node, handle =%d,%d\n",                i,ioc[i][2]);         is += 1;      }      if (mqueue[i][0]) {         fprintf(unit,"Non-empty receive queue end: node, handle =%d,%d\n",                i,mqueue[i][0]);         is += 1;      }      if (ioc[i][3]) {         fprintf(unit,"Incomplete send: node, handle =%d,%d\n",                i,ioc[i][3]);         is += 1;      }      if (mqueue[i][1]) {         fprintf(unit,"Non-empty send queue end: node, handle =%d,%d\n",                i,mqueue[i][1]);         is += 1;      }   }   i = MAXS;   if (ioc[i][3]) {      fprintf(unit,"Incomplete selfsend: node, handle =%d,%d\n",             idproc,ioc[i][3]);      is += 1;   }   if (mqueue[i][1]) {      fprintf(unit,"Non-empty selfsend queue end: node, handle =%d,%d\n",             idproc,mqueue[i][1]);      is += 1;   }   if (is > 0)      fprintf(unit,"\n");   return;}void messwin(int nvp) {/* this subroutine creates a window for showing MPI message status   nvp = number of real or virtual processors   input argument: nvplocal data                                                    */   Rect wrect, trect;   short iw, is, ix, iy, it;   GDevice** handle;   GrafPtr wptr;   int n, i;   char name[37];/* internal mpi common block   nproc = number of real or virtual processors obtained      *//* common block for message window   cpptr = pointer to window structure   crect = current drag region   nsp = amount of space between boxes   nbx = size of box   nds = number of message sizes monitored   mbs = maximum maximum bandwidth in MB/sec expected         *//* get handle to main graphics device that carries a menu bar */   handle = GetMainDevice();/* get size of screen */   crect.bottom = (*handle)->gdRect.bottom;   crect.right = (*handle)->gdRect.right;   wrect.bottom = crect.bottom - 40;   wrect.right = crect.right - 12;/* find which grafPort is currently active */   GetPort(&wptr);/* calculate size of window */   n = imin(nvp,nproc);   wrect.top = wrect.bottom - 2*(nbx + nsp) - nbx;   wrect.left = wrect.right - ((nbx + nsp)*imax(n,8) + nsp);/* add more space for distribution function */   wrect.top -= (6*nbx + nsp);/* add more space for speedometer */   wrect.top -= (4*nbx + nsp);/* add more space for user-defined label */   wrect.top -= nbx;/* name = label for window */   strcpy(name," MacMPI");   name[0] = 6;/* create a window */   if (!cpptr)      cpptr = NewCWindow(NULL,&wrect,(unsigned char *)name,                             1,4,(WindowPtr)(-1),0,0);/* activate a GrafPort */   SetPort(GetWindowPort(cpptr));/* keep a rectangular area from being updated */   GetPortBounds(GetWindowPort(cpptr),&trect);   ValidWindowRect(cpptr,&trect);/* calculate clipping region */   wrect.bottom -= wrect.top;   wrect.right -= wrect.left;   wrect.top = 0;   wrect.left = 0;/* select color to use in foreground drawing to black */   BackColor(33);/* fill rectangle with background pattern */   EraseRect(&wrect);/* calculate drag region */   crect.top = 4;   crect.left = 4;   crect.bottom -= 4;   crect.right -= 4;/* select color to use in foreground drawing to white */   ForeColor(30);/* set dimensions of pen for current Grafport */   PenSize(1,1);/* set point size for subsequent text drawing to 12 points */   TextSize(12);/* set initial x and y coordinates for label */   iw = nbx + nsp;   ix = nsp;   iy = iw + nbx;/* write label for processor id */   for (i = 0; i < n; i++) {/* convert node number to string */      sprintf(name,"%2d",i);/* get width of unformatted text */      is = TextWidth(name,0,2);/* set pen location without drawing */      MoveTo(ix+(nbx-is)/2,iy);/* draw text from any arbitrary buffer */      DrawText(name,0,2);/* update x coordinate */      ix += iw;   }/* write label for message state display */   strcpy(name,"Send=Green,Receive=Red,Both=Yellow");/* set point size for subsequent text drawing to 10 points */   TextSize(10);   ix = nsp;   iy = nsp + 3*nbx;/* set pen location without drawing */   MoveTo(ix,iy);/* select color to use in foreground drawing to green */   ForeColor(341);/* draw text from any arbitrary buffer */   DrawText(name,0,11);/* get width of unformatted text */   is = TextWidth(name,0,11);   ix += is;/* set pen location without drawing */   MoveTo(ix,iy);/* select color to use in foreground drawing to red */   ForeColor(205);/* draw text from any arbitrary buffer */   DrawText(name,11,12);/* get width of unformatted text */   is = TextWidth(name,11,12);   ix += is;/* set pen location without drawing */   MoveTo(ix,iy);/* select color to use in foreground drawing to yellow */   ForeColor(69);/* draw text from any arbitrary buffer */   DrawText(name,23,11);/* select color to use in foreground drawing to white */   ForeColor(30);/* set point size for subsequent text drawing to 9 points */   TextSize(9);/* set initial x and y coordinates for label */   it = nbx/4;   iw = nbx/2 + nsp;   ix = nsp;   iy = 8*nbx + 2*nsp;/* write label for message size, odd numbers only */   for (i = 0; i < nds; i+=2) {/* convert node number to string */      sprintf(name,"%2d",i);/* get width of unformatted text */      is = TextWidth(name,0,2);/* set pen location without drawing */      MoveTo(ix+(it-is)/2,iy);/* draw text from any arbitrary buffer */      DrawText(name,0,2);/* underline location of half maximum */      if (i==12) {         MoveTo(ix+(it-is)/2,iy+3);         DrawText("__",0,2);      }/* update x coordinate */      ix += iw;   }/* write second label */   strcpy(name,"Log2 Number vs. Log2 Message Size");/* set point size for subsequent text drawing to 10 points */   TextSize(10);/* set pen location without drawing */   MoveTo(nsp,9*nbx+2*nsp);/* draw text from any arbitrary buffer */   DrawText(name,0,33);/* set rectangle for speedometer */   wrect.top = 9*nbx + 3*nsp;   wrect.left = 2*nsp;   wrect.bottom = wrect.top + 4*nbx + 6;   iy = 11*nbx + 3*nsp + 2;/* set point size for subsequent text drawing to 9 points */   TextSize(9);   for (i = 0; i < 2; i++) {      if (i==1) wrect.left += 4*(nbx + nsp) + (nsp - 2);      wrect.right = wrect.left + 4*nbx + 1;/* set dimensions of pen for current Grafport */      PenSize(2,2);/* fill a wedge with current pen pattern and mode */      PaintArc(&wrect,-90,180);      if (i==0) {/* select color to use in foreground drawing to cyan */         ForeColor(273);/* write third label */         strcpy(name,"Communication % ");      }      else if (i==1) {/* select color to use in foreground drawing to red */         ForeColor(205);/* write third label */         strcpy(name,"Receiving (MB/s)");      }/* draw an arc */      FrameArc(&wrect,-90,180);/* set pen location without drawing */      MoveTo(wrect.left,iy+1);/* draw a line to specified coordinates */      LineTo(wrect.right-2,iy+1);/* set dimensions of pen for current Grafport */      PenSize(1,1);/* select color to use in foreground drawing to white */      ForeColor(30);/* set pen location without drawing */      MoveTo(wrect.left-nsp+2,iy+nbx);/* draw text from any arbitrary buffer */      DrawText(name,0,16);/* set pen location without drawing */      MoveTo(wrect.left-nsp,iy);/* draw text from any arbitrary buffer */      DrawText("0",0,1);/* set pen location without drawing */      MoveTo(wrect.right+2,iy);/* convert node number to string */      if (i==0) {         sprintf(name,"%3d",100);/* draw text from any arbitrary buffer */         DrawText(name,0,3);      }      else {         sprintf(name,"%2d",mbs);/* draw text from any arbitrary buffer */         DrawText(name,0,2);      }   }/* write third label */   strcpy(name," Current and Average Message-Passing");/* set point size for subsequent text drawing to 10 points */   TextSize(10);/* set pen location without drawing */   MoveTo(nsp,13*nbx+3*nsp);/* draw text from any arbitrary buffer */   DrawText(name,0,36);/* activate the GrafPort that was originally active */   if (wptr)      SetPort(wptr);/* display status */   logmess(0,0,0,0,0);   return;}void logmess(int idp, int lstat, int lsize, int mticks, int tag) {/* this subroutine logs MPI message state change and displays status   idp = remote processor id   lstat = (-1,1,-2,2) = (clear send,add send,clear receive,add receive)   lstat = 0 means display current status for all processors   lsize = size of message (in bytes)   lsize = -1 means print out message size distribution function   mticks = wait time in microseconds   tag = message tag   input argument: idp, lstat, lsize, mticks, taglocal data                                                               */#define NDSIZE               24   int istat, istyle, i, i1, i2;   float ar, cr, at, ct;   double dt;/* mstat = number of outstanding sends and receives for each node   msize = message size distribution function   nmax = maximum number of messages in display   lmax = log2 of nmax   ssize/times = total bytes/time sent   rsize/timer = total bytes/time received   ptime = time since last short term average                     */   static int mstat[MAXS][2] = {{0,0}}, msize[2*NDSIZE] = {0};   static int lmax = 8, nmax = 256, nums = 0, numr = 0;   static double ssize[2] = {0.0,0.0}, times[2] = {0.0,0.0};   static double rsize[2] = {0.0,0.0}, timer[2] = {0.0,0.0};   static double ptime = 0.0;/* internal mpi common block   nproc = number of real or virtual processors obtained   idproc = processor id                                                 *//* internal common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages *//* check for errors */   if ((idp < 0) || (idp >= nproc))      return;/* print out message size distribution function */   if (lsize < 0) {      fprintf(unit2," Message Size Distribution Function\n");      i1 = 1;      for (i = 0; i < NDSIZE; i++) {         i2 = i + NDSIZE;         fprintf(unit2," Size(bytes) = %d Sends = %d Receives = %d\n",                i1,msize[i2],msize[i]-msize[i2]);         i1 = 2*i1;      }      dt = 1.0/MPI_Wtime();      i1 = 100.0*(float) (times[0]*dt) + .5;      ar = (float) (ssize[0]/times[0]);      fprintf(unit2," Sending Time = %d %% Speed = %f MB/s\n",i1,ar);      i1 = 100.0*(float) (timer[0]*dt) + .5;      ar = (float) (rsize[0]/timer[0]);      fprintf(unit2," Receiving Time = %d %% Speed = %f MB/s\n",i1,ar);      return;   }/* process message size and time data */   else if ((lstat < 0) && (lsize > 0)) {/* accumulate sending data */      if (lstat==(-1)) {         dt = 1.0e-6*(double) lsize;         ssize[0] += dt;         ssize[1] += dt;         dt = 1.0e-6*(double) mticks;         times[0] += dt;         times[1] += dt;/* calculate short term average */         nums += 1;         if (nums==4) {            nums = 0;            ssize[1] = 0.0;            times[1] = 0.0;         }      }/* accumulate receiving data */      else if (lstat==(-2)) {         dt = 1.0e-6*(double) lsize;         rsize[0] += dt;         rsize[1] += dt;         dt = 1.0e-6*(double) mticks;         timer[0] += dt;         timer[1] += dt;/* calculate short term average */         numr += 1;         if (numr==4) {            dt = MPI_Wtime();            ct = (float) ((int) (100.0*(float) ((times[0]+timer[0])/dt) + .5));            dt = dt - ptime;            at = (float) ((int) (100.0*(float) ((times[1]+timer[1])/dt) + .5));            ptime = MPI_Wtime();            cr = (float) (rsize[0]/timer[0]);            ar = (float) (rsize[1]/timer[1]);            shospeed(at,ct,ar,cr);            numr = 0;            rsize[1] = 0.0;            timer[1] = 0.0;         }      }/* increment message size distribution function */      i1 = imin((int) (log((float) (lsize))/log(2.) + .5),NDSIZE-1);      msize[i1] += 1;/* increment message size distribution function for sends */      i2 = i1 + NDSIZE;      if (lstat==(-1))         msize[i2] += 1;      if (msize[i1] > nmax) {/* erase display of distribution function */         showdism(0,nmax,0,lmax,0);         lmax += 1;         nmax += nmax;/* redisplay distribution function */         for (i = 0; i < NDSIZE; i++) {            showdism(i,msize[i],msize[i+NDSIZE],lmax,1);         }      }/* display distribution function */      else         showdism(i1,msize[i1],msize[i2],lmax,1);   }   i1 = idp;/* calculate all current statuses */   if (lstat==0) {      for (i = 0; i < nproc; i++) {         istat = 0;         if (mstat[i][0] >= 1)            istat += 1;         if (mstat[i][1] >= 1)            istat += 2;/* differentiate single from multiple sends/receives *//*       if ((mstat[i][0] > 1) || (mstat[i][1] > 1))            istat += 3;                              *//* display status, outline local node                */         if (i==idproc)            istyle = 1;         else            istyle = 0;         showmess(i,istat,istyle);      }/* display scale */      showdism(0,msize[0],msize[NDSIZE],lmax,0);/* display current distribution function */      for (i = 0; i < NDSIZE; i++) {         showdism(i,msize[i],msize[i+NDSIZE],lmax,1);      }      return;   }/* add state change to log */   else if (lstat==1) {      mstat[i1][0] += 1;      if (monitor==2)         fprintf(unit2,"send posted: destination= %d size= %d tag= %d\n",                 idp,lsize,tag);   }   else if (lstat==(-1)) {      mstat[i1][0] -= 1;      if (monitor==2)         fprintf(unit2,"sent: destination= %d size= %d time= %d tag= %d\n",                 idp,lsize,mticks,tag);   }   else if (lstat==2) {      mstat[i1][1] += 1;      if (monitor==2)         fprintf(unit2,"receive posted: source= %d size= %d tag= %d\n",                 idp,lsize,tag);   }   else if (lstat==(-2)) {      mstat[i1][1] -= 1;      if (monitor==2)         fprintf(unit2,"received: source= %d size= %d time= %d tag= %d\n",                 idp,lsize,mticks,tag);   }/* calculate current status */   istat = 0;   if (mstat[i1][0] >= 1)      istat += 1;   if (mstat[i1][1] >= 1)      istat += 2;/* differentiate single from multiple sends/receives *//* if ((mstat[i1][0] > 1) || (mstat[i1][1] > 1))      istat += 3;                                    *//* display status, outline local node */   if (idp==idproc)      istyle = 1;   else      istyle = 0;   showmess(idp,istat,istyle);   if (cpptr)/* flush window buffer to screen */      QDFlushPortBuffer(GetWindowPort(cpptr),0);   return;#undef NDSIZE}void showmess(int idp, int istat, int istyle) {/* this subroutine shows MPI message status   idp = remote processor id   istat = message status = (0,1,2,3) = (none,sending,receiving,both)   istyle = (0,1) = (no,yes) outline rectangle   input argument: idp, istat, istylelocal data                                                            */   Rect wrect;   GrafPtr wptr;/* icolor = white, green, red, yellow, blue, magenta, cyan, black */   const int icolor[8] = {30,341,205,69,409,137,273,33};/* internal common block for message window   cpptr = pointer to window structure   nsp = amount of space between boxes   nbx = size of box                         *//* check for errors */   if ((istat < 0) || (istat > 7))      return;   if (!cpptr)      return;/* find which grafPort is currently active */   GetPort(&wptr);/* activate a GrafPort */   SetPort(GetWindowPort(cpptr));/* set rectangle */   wrect.top = nsp;   wrect.left = (nbx + nsp)*idp + nsp;   wrect.bottom = wrect.top + nbx;   wrect.right = wrect.left + nbx;/* select color to use in foreground drawing */   ForeColor(icolor[istat]);/* draw the outline of a rectangle */   FrameRect(&wrect);/* fill rectangle with current pen pattern and mode */   PaintRect(&wrect);/* outline rectangle */   if (istyle) {/* shrink or expand a rectangle */      InsetRect(&wrect,-2,-2);/* draw the outline of a rectangle */      FrameRect(&wrect);   }/* activate the GrafPort that was originally active */   if (wptr)       SetPort(wptr);   return;}void showdism(int ibin,int nbin,int mbin,int lmax,int istyle) {/* this subroutine shows distribution of MPI messages   ibin = bin number for distribution function   nbin = number of total messages in ibin   mbin = number of send messages in ibin   lmax = log2 of maximum number of messages in display   istyle = (0,1) = (erase and rescale,draw) display    input argument: ibin, nbin, nmaxlocal data                                                */   Rect wrect;   short iw, nscale, nsub;   GrafPtr wptr;   float scale;   char name[9];/* internal common block for message window   cpptr = pointer to window structure   nsp = amount of space between boxes   nbx = size of box   nds = number of message sizes monitored    *//* check for errors */   if (!cpptr)      return;/* find which grafPort is currently active */   GetPort(&wptr);/* activate a GrafPort */   SetPort(GetWindowPort(cpptr));/* set rectangle for entire distribution */   iw = nbx/4;   wrect.bottom = 7*nbx + 2*nsp;/* erase and rescale display */   if (!istyle) {/* select color to use in foreground drawing to black */      ForeColor(33);      wrect.top = wrect.bottom - 4*nbx;      wrect.right = (iw + nsp/2)*nds + nsp/2;      wrect.left = 0;/* fill rectangle with background pattern */      EraseRect(&wrect);/* select color to use in foreground drawing to white */      ForeColor(30);/* set point size for subsequent text drawing to 9 points */      TextSize(9);/* convert node number to string */      sprintf(name,"%2d",lmax);/* set pen location without drawing */      MoveTo(0,wrect.top+9);/* draw text from any arbitrary buffer */      DrawText(name,0,2);   }/* draw display */   else {/* calculate size of total image */      scale = (float) (4*nbx)/(((float) (lmax))*log(2.));      nscale = imin((int) (log((float) (nbin+1))*scale),4*nbx);      if (!nbin)         goto L10;/* set width for individual bin */      wrect.right = (iw + nsp/2)*ibin + iw + nsp;      wrect.left = wrect.right - iw;/* calculate size of image for sends */	  nsub = (((float) (mbin))/((float) (nbin)))*((float) (nscale)) + .5;/* set height of individual bin for sends */      wrect.top = wrect.bottom - nsub;/* select color to use in foreground drawing to green */      ForeColor(341);/* draw the outline of a rectangle */      FrameRect(&wrect);/* fill rectangle with current pen pattern and mode */      PaintRect(&wrect);/* set height of individual bin for receives */      wrect.top = wrect.bottom - nscale;      wrect.bottom = wrect.bottom - nsub;/* select color to use in foreground drawing to red */      ForeColor(205);/* draw the outline of a rectangle */      FrameRect(&wrect);/* fill rectangle with current pen pattern and mode */      PaintRect(&wrect);   }/* activate the GrafPort that was originally active */L10: if (wptr)      SetPort(wptr);   return;}void shospeed(float atime,float ctime,float arate,float crate) {/* this subroutine shows communication rates for MPI messages   atime = short term average communication time (% of total)   ctime = long term average communication time (% of total)   arate = short term average reception rate (MB/sec)   crate = long term average reception rate (MB/sec)   input argument: atime, ctime, arate, cratelocal data                                                       */   float scale, angle, dx;   const float pi=.5*6.28318530717959;   short ix0, iy0;   static short ix[4] = {0,0,0,0}, iy[4] = {0,0,0,0};   GrafPtr wptr;   int i;/* internal common block for message window  cpptr = pointer to window structure  nsp = amount of space between boxes  nbx = size of box  mbs = maximum maximum bandwidth in MB/sec expected *//* check for errors */   if (!cpptr)      return;/* find which grafPort is currently active */   GetPort(&wptr);/* activate a GrafPort */   SetPort(GetWindowPort(cpptr));/* set dimensions of pen for current Grafport */   PenSize(2,2);/* find center of speedometer */   iy0 = 11*nbx + 3*nsp + 1;/* parameters for communication plot */   ix0 = 2*(nbx + nsp) + 1;   scale = .01;/* plot speedometer lines */   for (i = 0; i < 4; i++) {/* parameters for reception plot */      if (i==2) {         ix0 += 4*(nbx + nsp) + (nsp - 2);         scale = 1./(float) mbs;      }/* erase old speedometer line *//* select color to use in foreground drawing to white */      ForeColor(30);/* set pen location without drawing */      MoveTo(ix0,iy0);/* draw a line a specified distance */      Line(ix[i],-iy[i]);/* draw new speedometer line */      if (i==0) {/* select color to use in foreground drawing to cyan */         ForeColor(273);         angle = flmax(0.,(1. - atime*scale))*pi;      }      else if (i==1) {/* select color to use in foreground drawing to black */         ForeColor(33);         angle = flmax(0.,(1. - ctime*scale))*pi;      }      else if (i==2) {/* select color to use in foreground drawing to red */         ForeColor(205);         angle = flmax(0.,(1. - arate*scale))*pi;      }      else if (i==3) {/* select color to use in foreground drawing to black */         ForeColor(33);         angle = flmax(0.,(1. - crate*scale))*pi;      }      dx = (float) (2*nbx-3);      ix[i] = dx*cos(angle) + .5;      iy[i] = dx*sin(angle) + .5;/* set pen location without drawing */      MoveTo(ix0,iy0);/* draw a line a specified distance */      Line(ix[i],-iy[i]);   }/* set dimensions of pen for current Grafport */   PenSize(1,1);/* activate the GrafPort that was originally active */   if (wptr)      SetPort(wptr);   return;}void Logname(char* name) {/* this subroutine records and displays user-defined label   name = label to displaylocal data                                                  */   Rect wrect;   short nl;   GrafPtr wptr;/* internal common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages *//* internal common block for message window   cpptr = pointer to window structure   nsp = amount of space between boxes   nbx = size of box                          */   if (monitor==0)      return;   if (monitor==2)      fprintf(unit2,"%s",name);/* check for errors */   if (!cpptr)      return;/* find which grafPort is currently active */   GetPort(&wptr);/* activate a GrafPort */   SetPort(GetWindowPort(cpptr));/* set rectangle */   wrect.top = 13*nbx + 3*nsp + 2;   wrect.left = nsp;   wrect.bottom = wrect.top + nbx;   wrect.right = wrect.left + 8*(nbx + nsp);/* select color to use in foreground drawing to black */   BackColor(33);/* fill rectangle with background pattern */   EraseRect(&wrect);/* select color to use in foreground drawing to white */   ForeColor(30);/* set pen location without drawing */   MoveTo(wrect.left,wrect.bottom-2);   nl = imin(36,strlen(name));/* draw text from any arbitrary buffer */   DrawText(name,0,nl);/* activate the GrafPort that was originally active */   if (wptr)      SetPort(wptr);   return;}void Set_Mon(int monval) {/* this subroutine sets new monitor value and corresponding window   monval = new monitor value                                            *//* declare internal mpi common block   nproc = number of real or virtual processors obtained                 *//* declare common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages *//* create or destroy window if MPI has been initialized */   if (nproc > 0) {/* open window */      if ((monitor==0) && (monval > 0))         messwin(nproc);/* close window */      if ((monitor > 0) && (monval < 1))         delmess();   }/* reset monitor value */   if (monval > 1)      monitor = 2;   else if (monval < 1)      monitor = 0;   else      monitor = 1;   return;}int Get_Mon() {/* this function gets current monitor value *//* declare common block for non-blocking messages   monitor = (0,1,2) = (suppress,display,display & log) monitor messages */   return monitor;}void delmess() {/* this subroutine closes a window for showing MPI message status/* internal common block for message window   cpptr = pointer to window structure *//* remove window from screen; keep WindowRecord */   if (cpptr)      DisposeWindow(cpptr);   cpptr = 0;   return;}
